diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-14 19:50:44 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-14 19:50:44 +0100 |
commit | 2cf1705c72212808532ba25cde19f30ce84118a2 (patch) | |
tree | 762b2e00a4bcd2d5c209cd1f838b3a7f9d0ac3cc | |
parent | 194566b0ec93ae8953dcea06a62fdcb99c7e43dd (diff) | |
download | guile-2cf1705c72212808532ba25cde19f30ce84118a2.tar.gz |
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.
-rw-r--r-- | module/language/assembly.scm | 17 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 102 |
2 files changed, 71 insertions, 48 deletions
diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 734deb580..fbe3a7153 100644 --- a/module/language/assembly.scm +++ b/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 ;;; diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 650a3dac1..5679b6898 100644 --- a/module/language/glil/compile-assembly.scm +++ b/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 subcode)))))))) + (addr+ 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 - ((object->assembly x) => list) - ((variable-cache-cell? x) (dump (variable-cache-cell-key x))) - ((subprogram? x) (subprogram-code x)) - ((and (integer? x) (exact? x)) - (let ((str (do ((n x (quotient n 256)) - (l '() (cons (modulo n 256) l))) - ((= n 0) - (list->string (map integer->char l)))))) - `((load-integer ,str)))) - ((number? x) - `((load-number ,(number->string x)))) - ((string? x) - `((load-string ,x))) - ((symbol? x) - `((load-symbol ,(symbol->string x)))) - ((keyword? x) - `((load-keyword ,(symbol->string (keyword->symbol x))))) - ((list? x) - (fold append - (let ((len (length x))) - (if (>= len 65536) (too-long "list")) - `((list ,(quotient len 256) ,(modulo len 256)))) - (fold (lambda (x y) (cons (dump x) y)) - '() - x))) - ((pair? x) - `(,@(dump (car x)) - ,@(dump (cdr x)) - (cons))) - ((vector? x) - (fold append - (let ((len (vector-length x))) - (if (>= len 65536) (too-long "vector")) - `((vector ,(quotient len 256) ,(modulo len 256)))) - (fold (lambda (x y) (cons (dump x) y)) - '() - (vector->list x)))) - (else - (error "assemble: unrecognized object" x))))) + (cond + ((object->assembly x) => list) + ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) + ((subprogram? x) + `(,@(subprogram-table x) + ,@(align-program (subprogram-prog x) + (addr+ addr (subprogram-table x))))) + ((and (integer? x) (exact? x)) + (let ((str (do ((n x (quotient n 256)) + (l '() (cons (modulo n 256) l))) + ((= n 0) + (list->string (map integer->char l)))))) + `((load-integer ,str)))) + ((number? x) + `((load-number ,(number->string x)))) + ((string? x) + `((load-string ,x))) + ((symbol? x) + `((load-symbol ,(symbol->string x)))) + ((keyword? x) + `((load-keyword ,(symbol->string (keyword->symbol x))))) + ((list? x) + (let ((tail (let ((len (length x))) + (if (>= len 65536) (too-long "list")) + `((list ,(quotient len 256) ,(modulo len 256)))))) + (let dump-objects ((objects x) (codes '()) (addr addr)) + (if (null? objects) + (fold append tail codes) + (let ((code (dump-object (car objects) addr))) + (dump-objects (cdr objects) (cons code codes) + (addr+ addr code))))))) + ((pair? x) + (let ((kar (dump-object (car x) addr))) + `(,@kar + ,@(dump-object (cdr x) (addr+ addr kar)) + (cons)))) + ((vector? x) + (let* ((len (vector-length x)) + (tail (if (>= len 65536) + (too-long "vector") + `((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)))) |