align programs on 8-byte boundaries

* module/language/assembly.scm (addr+): New helper.
  (align-program): New function, aligns a (load-program) form, currently
  to 8-byte boundaries.

* module/language/glil/compile-assembly.scm (<subprogram>): Record the
  object table and the program code separately, so that we can align the
  program after the object table has been written.
  (glil->assembly): Use addr+.
  (dump-object): Rework to fold `addr' through dumping of compound
  objects, so that procedures can be aligned properly.

module/language/assembly.scm

@@ -22,7 +22,9 @@
 (define-module (language assembly)
   #:use-module (system base pmatch)
   #:use-module (system vm instruction)
+  #:use-module ((srfi srfi-1) #:select (fold))
   #:export (byte-length
+            addr+ align-program
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
@@ -54,6 +56,21 @@
      (+ 1 (instruction-length inst)))
     (else (error "unknown instruction" assembly))))
 
+
+(define *program-alignment* 8)
+
+(define (addr+ addr code)
+  (fold (lambda (x len) (+ (byte-length x) len))
+        addr
+        code))
+
+(define (align-program prog addr)
+  `(,@(make-list (modulo (- *program-alignment*
+                            (modulo addr *program-alignment*))
+                         *program-alignment*)
+                 '(nop))
+    ,prog))
+
 ;;;
 ;;; Code compress/decompression
 ;;;

module/language/glil/compile-assembly.scm

@@ -39,9 +39,10 @@
 (define-record <variable-cache-cell> key)
 
 ;; Subprograms can be loaded into an object table as well. We need a
-;; disjoint type here too.
+;; disjoint type here too. (Subprograms have their own object tables --
+;; though probably we should just make one table per compilation unit.)
 
-(define-record <subprogram> code)
+(define-record <subprogram> table prog)
 
 
 (define (limn-sources sources)
@@ -162,8 +163,7 @@
                                    source-alist label-alist object-alist addr)
                  (lp (cdr body) (append (reverse subcode) code)
                      bindings source-alist label-alist object-alist
-                     (fold (lambda (x len) (+ (byte-length x) len))
+                     (addr+ addr subcode))))))))
-                           addr subcode))))))))
 
        (receive (code bindings sources labels objects len)
            (process-body)
@@ -185,7 +185,7 @@
                  ;; if we are being compiled from something with an object
                  ;; table, cache the program there
                  (receive (i object-alist)
-                     (object-index-and-alist (make-subprogram `(,@table ,prog))
+                     (object-index-and-alist (make-subprogram table prog)
                                              object-alist)
                    (emit-code/object `((object-ref ,i) ,@closure)
                                      object-alist)))
@@ -326,51 +326,57 @@
     ((<glil-mv-call> nargs ra)
      (emit-code `((mv-call ,nargs ,ra))))))
 
-;; addr is currently unused, but could be used to align data in the
-;; instruction stream.
 (define (dump-object x addr)
   (define (too-long x)
     (error (string-append x " too long")))
 
-  (let dump ((x x))
+  (cond
-    (cond
+   ((object->assembly x) => list)
-     ((object->assembly x) => list)
+   ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
-     ((variable-cache-cell? x) (dump (variable-cache-cell-key x)))
+   ((subprogram? x)
-     ((subprogram? x) (subprogram-code x))
+    `(,@(subprogram-table x)
-     ((and (integer? x) (exact? x))
+      ,@(align-program (subprogram-prog x)
-      (let ((str (do ((n x (quotient n 256))
+                       (addr+ addr (subprogram-table x)))))
-                      (l '() (cons (modulo n 256) l)))
+   ((and (integer? x) (exact? x))
-                     ((= n 0)
+    (let ((str (do ((n x (quotient n 256))
-                      (list->string (map integer->char l))))))
+                    (l '() (cons (modulo n 256) l)))
-        `((load-integer ,str))))
+                   ((= n 0)
-     ((number? x)
+                    (list->string (map integer->char l))))))
-      `((load-number ,(number->string x))))
+      `((load-integer ,str))))
-     ((string? x)
+   ((number? x)
-      `((load-string ,x)))
+    `((load-number ,(number->string x))))
-     ((symbol? x)
+   ((string? x)
-      `((load-symbol ,(symbol->string x))))
+    `((load-string ,x)))
-     ((keyword? x)
+   ((symbol? x)
-      `((load-keyword ,(symbol->string (keyword->symbol x)))))
+    `((load-symbol ,(symbol->string x))))
-     ((list? x)
+   ((keyword? x)
-      (fold append
+    `((load-keyword ,(symbol->string (keyword->symbol x)))))
-            (let ((len (length x)))
+   ((list? x)
-              (if (>= len 65536) (too-long "list"))
+    (let ((tail (let ((len (length x)))
-              `((list ,(quotient len 256) ,(modulo len 256))))
+                  (if (>= len 65536) (too-long "list"))
-            (fold (lambda (x y) (cons (dump x) y))
+                  `((list ,(quotient len 256) ,(modulo len 256))))))
-                  '()
+      (let dump-objects ((objects x) (codes '()) (addr addr))
-                  x)))
+        (if (null? objects)
-     ((pair? x)
+            (fold append tail codes)
-      `(,@(dump (car x))
+            (let ((code (dump-object (car objects) addr)))
-        ,@(dump (cdr x))
+              (dump-objects (cdr objects) (cons code codes)
-        (cons)))
+                            (addr+ addr code)))))))
-     ((vector? x)
+   ((pair? x)
-      (fold append
+    (let ((kar (dump-object (car x) addr)))
-            (let ((len (vector-length x)))
+      `(,@kar
-              (if (>= len 65536) (too-long "vector"))
+        ,@(dump-object (cdr x) (addr+ addr kar))
-              `((vector ,(quotient len 256) ,(modulo len 256))))
+        (cons))))
-            (fold (lambda (x y) (cons (dump x) y))
+   ((vector? x)
-                  '()
+    (let* ((len (vector-length x))
-                  (vector->list x))))
+           (tail (if (>= len 65536)
-     (else
+                     (too-long "vector")
-      (error "assemble: unrecognized object" x)))))
+                     `((vector ,(quotient len 256) ,(modulo len 256))))))
+      (let dump-objects ((i 0) (codes '()) (addr addr))
+        (if (>= i len)
+            (fold append tail codes)
+            (let ((code (dump-object (vector-ref x i) addr)))
+              (dump-objects (1+ i) (cons code codes)
+                            (addr+ addr code)))))))
+   (else
+    (error "assemble: unrecognized object" x))))