linker string tables are stateful objects

* module/system/vm/linker.scm (make-string-table): Rework to be a
  stateful object instead of a function object.  Works better in this
  case.  Adapt users.
  (string-table-intern!): Rename from string-table-intern, and just
  return the index of the string.
  (link-string-table!): Rename from link-string-table, and set a flag to
  prevent interning strings after linking, as that's not going to work
  well.

* module/language/objcode/elf.scm (bytecode->elf): Adapt.

diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
index 981c398..ddbd7b2 100644 (file)
--- a/module/language/objcode/elf.scm
+++ b/module/language/objcode/elf.scm
@@ -36,11 +36,7 @@
 (define (bytecode->elf bv)
   (let ((string-table (make-string-table)))
     (define (intern-string! string)
-      (call-with-values
-          (lambda () (string-table-intern string-table string))
-        (lambda (table idx)
-          (set! string-table table)
-          idx)))
+      (string-table-intern! string-table string))
     (define (make-object index name bv relocs . kwargs)
       (let ((name-idx (intern-string! (symbol->string name))))
         (make-linker-object (apply make-elf-section
@@ -79,7 +75,7 @@
                        #:type SHT_DYNAMIC #:flags SHF_ALLOC))))
     (define (make-string-table index)
       (intern-string! ".shstrtab")
-      (make-object index '.shstrtab (link-string-table string-table) '()
+      (make-object index '.shstrtab (link-string-table! string-table) '()
                    #:type SHT_STRTAB #:flags 0))
     (let* ((word-size (target-word-size))
            (endianness (target-endianness))

diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index a5d43f2..9a51778 100644 (file)
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -85,8 +85,8 @@
             (linker-object-symbols* . linker-object-symbols)
 
             make-string-table
-            string-table-intern
-            link-string-table
+            string-table-intern!
+            link-string-table!
 
             link-elf))
 
@@ -156,40 +156,52 @@
   "Return the linker symbols defined by the user for this this section."
   (cdr (linker-object-symbols object)))
 
+(define-record-type <string-table>
+  (%make-string-table strings linked?)
+  string-table?
+  (strings string-table-strings set-string-table-strings!)
+  (linked? string-table-linked? set-string-table-linked?!))
+
 (define (make-string-table)
-  "Return a functional string table with one entry: the empty string."
-  '(("" 0 #vu8())))
-
-(define (string-table-length table)
-  "Return the number of bytes needed for the string table @var{table}."
-  (let ((last (car table)))
-    ;; The + 1 is for the trailing NUL byte.
-    (+ (cadr last) (bytevector-length (caddr last)) 1)))
-
-(define (string-table-intern table str)
-  "Add @var{str} to the string table @var{table}.  Yields two values:  a
-possibly newly allocated string table, and the byte index of the string
-in that table."
-  (cond
-   ((assoc str table)
-    => (lambda (ent)
-         (values table (cadr ent))))
-   (else
-    (let* ((next (string-table-length table)))
-      (values (cons (list str next (string->utf8 str))
-                    table)
-              next)))))
-
-(define (link-string-table table)
+  "Return a string table with one entry: the empty string."
+  (%make-string-table '(("" 0 #vu8())) #f))
+
+(define (string-table-length strings)
+  "Return the number of bytes needed for the @var{strings}."
+  (match strings
+    (((str pos bytes) . _)
+     ;; The + 1 is for the trailing NUL byte.
+     (+ pos (bytevector-length bytes) 1))))
+
+(define (string-table-intern! table str)
+  "Ensure that @var{str} is present in the string table @var{table}.
+Returns the byte index of the string in that table."
+  (match table
+    (($ <string-table> strings linked?)
+     (match (assoc str strings)
+       ((_ pos _) pos)
+       (#f
+        (let ((next (string-table-length strings)))
+          (when linked?
+            (error "string table already linked, can't intern" table str))
+          (set-string-table-strings! table
+                                     (cons (list str next (string->utf8 str))
+                                           strings))
+          next))))))
+
+(define (link-string-table! table)
   "Link the functional string table @var{table} into a sequence of
 bytes, suitable for use as the contents of an ELF string table section."
-  (let ((out (make-bytevector (string-table-length table) 0)))
-    (for-each
-     (lambda (ent)
-       (let ((bytes (caddr ent)))
-         (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
-     table)
-    out))
+  (match table
+    (($ <string-table> strings #f)
+     (let ((out (make-bytevector (string-table-length strings) 0)))
+       (for-each
+        (match-lambda
+         ((_ pos bytes)
+          (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
+        strings)
+       (set-string-table-linked?! table #t)
+       out))))
 
 (define (segment-kind section)
   "Return the type of segment needed to store @var{section}, as a pair.