summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-14 19:50:44 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-14 19:50:44 +0100
commit2cf1705c72212808532ba25cde19f30ce84118a2 (patch)
tree762b2e00a4bcd2d5c209cd1f838b3a7f9d0ac3cc
parent194566b0ec93ae8953dcea06a62fdcb99c7e43dd (diff)
downloadguile-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.scm17
-rw-r--r--module/language/glil/compile-assembly.scm102
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))))