;;; Guile x86-32 assembler ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language glil compile-sassy) #:use-module (system base syntax) #:use-module (system base pmatch) #:use-module (language glil) #:use-module (language assembly) #:use-module (system vm instruction) #:use-module ((system vm program) #:select (make-binding)) #:use-module (ice-9 receive) #:use-module ((srfi srfi-1) #:select (fold)) #:use-module (rnrs bytevector) #:export (compile-assembly)) ;; Variable cache cells go in the object table, and serialize as their ;; keys. The reason we wrap the keys in these records is so they don't ;; compare as `equal?' to other objects in the object table. ;; ;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?) (define-record key) ;; Subprograms can be loaded into an object table as well. We need a ;; disjoint type here too. (Subprograms have their own object tables -- ;; though probably we should just make one table per compilation unit.) (define-record table prog) (define (limn-sources sources) (let lp ((in sources) (out '()) (filename #f)) (if (null? in) (reverse! out) (let ((addr (caar in)) (new-filename (assq-ref (cdar in ) 'filename)) (line (assq-ref (cdar in) 'line)) (column (assq-ref (cdar in) 'column))) (cond ((not (equal? new-filename filename)) (lp (cdr in) `((,addr . (,line . ,column)) (filename . ,new-filename) . ,out) new-filename)) ((or (null? out) (not (equal? (cdar out) `(,line . ,column)))) (lp (cdr in) `((,addr . (,line . ,column)) . ,out) filename)) (else (lp (cdr in) out filename))))))) (define (make-meta bindings sources tail) (if (and (null? bindings) (null? sources) (null? tail)) #f (compile-sassy (make-glil-program 0 0 0 '() (list (make-glil-const `(,bindings ,sources ,@tail)) (make-glil-call 'return 1)))))) ;; A functional stack of names of live variables. (define (make-open-binding name boxed? index) (list name boxed? index)) (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) (define (open-binding bindings vars start) (cons (acons start (map (lambda (v) (pmatch v ((,name ,boxed? ,i) (make-open-binding name boxed? i)) (else (error "unknown binding type" v)))) vars) (car bindings)) (cdr bindings))) (define (close-binding bindings end) (pmatch bindings ((((,start . ,closing) . ,open) . ,closed) (cons open (fold (lambda (o tail) ;; the cons is for dsu sort (acons start (make-closed-binding o start end) tail)) closed closing))) (else (error "broken bindings" bindings)))) (define (close-all-bindings bindings end) (if (null? (car bindings)) (map cdr (stable-sort (reverse (cdr bindings)) (lambda (x y) (< (car x) (car y))))) (close-all-bindings (close-binding bindings end) end))) ;; A functional object table. (define *module* 1) (define (assoc-ref-or-acons alist x make-y) (cond ((assoc-ref alist x) => (lambda (y) (values y alist))) (else (let ((y (make-y x alist))) (values y (acons x y alist)))))) (define (object-index-and-alist x alist) (assoc-ref-or-acons alist x (lambda (x alist) (+ (length alist) *module*)))) (define *true* #x104) (define *false* #x4) (define *null* #x404) (define *fixnum-tag* #b10) (define *fixnum-shift* 2) (define *char-tag* #b00001100) (define *char-shift* 8) (define (compile-sassy glil) (receive (code . _) (glil->sassy glil #t '(()) '() #f) (car code))) (define (make-object-table objects) (and (not (null? objects)) (list->vector (cons #f objects)))) (define (glil->sassy glil toplevel? bindings source-alist object-alist) (define (emit-code x) (values x bindings source-alist object-alist)) (define (emit-code/object x object-alist) (values x bindings source-alist object-alist)) (record-case glil (( nargs nrest nlocs meta body) (define (process-body) (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) (object-alist (if toplevel? #f '()))) (cond ((null? body) (values (reverse code) (close-all-bindings bindings addr) (limn-sources (reverse! source-alist)) (and object-alist (map car (reverse object-alist))))) (else (receive (subcode bindings source-alist object-alist) (glil->assembly (car body) #f bindings source-alist object-alist) (lp (cdr body) (append (reverse subcode) code) bindings source-alist object-alist)))))) (receive (code bindings sources objects) (process-body) (let* ((meta (make-meta bindings sources meta)) (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)) (prog `(load-program ,nargs ,nrest ,nlocs ,labels ,(+ len meta-pad) ,meta ,@code ,@(if meta (make-list meta-pad '(nop)) '())))) (cond (toplevel? ;; toplevel bytecode isn't loaded by the vm, no way to do ;; object table or closure capture (not in the bytecode, ;; anyway) (emit-code (list prog))) (else (let ((table (make-object-table objects))) (cond (object-alist ;; 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-alist) (emit-code/object `(,(if (< i 256) `(object-ref ,i) `(long-object-ref ,(quotient i 256) ,(modulo i 256)))) object-alist))) (else ;; otherwise emit a load directly (let ((table-code (dump-object table addr))) (emit-code `(,@table-code ,@(align-program prog (addr+ addr table-code))))))))))))) (( vars) (values '() (open-binding bindings vars addr) source-alist object-alist)) (( vars rest) (values `((truncate-values ,(length vars) ,(if rest 1 0))) (open-binding bindings vars addr) source-alist object-alist)) (() (values '() (close-binding bindings addr) source-alist object-alist)) (( props) (values '() bindings (acons addr props source-alist) object-alist)) (() (emit-code '((void)))) (( obj) (cond ((object->assembly obj) => (lambda (code) (emit-code (list code)))) ((not object-alist) (emit-code (dump-object obj addr))) (else (receive (i object-alist) (object-index-and-alist obj object-alist) (emit-code/object (if (< i 256) `((object-ref ,i)) `((long-object-ref ,(quotient i 256) ,(modulo i 256)))) object-alist))))) (( local? boxed? op index) (emit-code (if local? (if (< index 256) (case op ((ref) (if boxed? `((local-boxed-ref ,index)) `((local-ref ,index)))) ((set) (if boxed? `((local-boxed-set ,index)) `((local-set ,index)))) ((box) `((box ,index))) ((empty-box) `((empty-box ,index))) ((fix) `((fix-closure 0 ,index))) (else (error "what" op))) (let ((a (quotient i 256)) (b (modulo i 256))) `((,(case op ((ref) (if boxed? `((long-local-ref ,a ,b) (variable-ref)) `((long-local-ref ,a ,b)))) ((set) (if boxed? `((long-local-ref ,a ,b) (variable-set)) `((long-local-set ,a ,b)))) ((box) `((make-variable) (variable-set) (long-local-set ,a ,b))) ((empty-box) `((make-variable) (long-local-set ,a ,b))) ((fix) `((fix-closure ,a ,b))) (else (error "what" op))) ,index)))) `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) (else (error "what" op))) ,index))))) (( op name) (case op ((ref set) (cond ((not object-alist) (emit-code `(,@(dump-object name addr) (link-now) ,(case op ((ref) '(variable-ref)) ((set) '(variable-set)))))) (else (receive (i object-alist) (object-index-and-alist (make-variable-cache-cell name) object-alist) (emit-code/object (if (< i 256) `((,(case op ((ref) 'toplevel-ref) ((set) 'toplevel-set)) ,i)) `((,(case op ((ref) 'long-toplevel-ref) ((set) 'long-toplevel-set)) ,(quotient i 256) ,(modulo i 256)))) object-alist))))) ((define) (emit-code `(,@(dump-object name addr) (define)))) (else (error "unknown toplevel var kind" op name)))) (( op mod name public?) (let ((key (list mod name public?))) (case op ((ref set) (cond ((not object-alist) (emit-code `(,@(dump-object key addr) (link-now) ,(case op ((ref) '(variable-ref)) ((set) '(variable-set)))))) (else (receive (i object-alist) (object-index-and-alist (make-variable-cache-cell key) object-alist) (emit-code/object (case op ((ref) `((toplevel-ref ,i))) ((set) `((toplevel-set ,i)))) object-alist))))) (else (error "unknown module var kind" op key))))) (( label) (values `((label ,label)) bindings source-alist object-alist)) (( inst label) (emit-code (case inst ((br) `((jmp ,label))) ((br-if) `((pop eax) (cmp eax ,*false*) (jne ,label))) ((br-if-not) `((pop eax) (cmp eax ,*false*) (je ,label))) (else (error "unrecognized inst" inst))))) ;; nargs is number of stack args to insn. probably should rename. (( inst nargs) ;; verify the inst (if (not (instruction? inst)) (error "Unknown instruction:" inst)) (let ((pops (instruction-pops inst))) (cond ((< pops 0) (case (instruction-length inst) ((1 2) #t) (else (error "Unknown length for variable-arg instruction:" inst (instruction-length inst))))) ((= pops nargs) #t) (else (error "Wrong number of stack arguments to instruction:" inst nargs)))) (emit-code (case inst ((add) `((locals (fix post) (pop ebx) (pop eax) (add eax ebx) (jno fix) ;;segfault (mov eax 0) (add eax (& eax)) (jmp post) (label fix) (sub eax ,*fixnum-tag*) (label post) (push eax))))) (else (error "unhandled instruction" inst)))) (( nargs ra) (error "mv-call not yet supported")))) (define (dump-object x) (define (too-long x) (error (string-append x " too long"))) (cond ((eq? x #t) `((push ,*true*))) ((eq? x #f) `((push ,*false*))) ((null? x) `((push ,*null*))) ((and (integer? x) (exact? x) (<= most-negative-fixnum x) (<= x most-positive-fixnum)) `((push ,(logior (ash x *fixnum-shift*) *fixnum-tag*)))) ((char? x) `((push ,(logior (ash (char->integer x) *char-shift*) *char-tag*)))) ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x))) ((subprogram? x) (let ((table-code )) `(,@(dump-object (subprogram-table x)) ,(subprogram-prog x)) )) ((number? x) `((load-number ,(number->string x)))) ((string? x) (case (string-width x) ((1) `((load-string ,x))) ((4) (align-code `(load-wide-string ,x) addr 4 4)) (else (error "bad string width" x)))) ((symbol? x) (let ((str (symbol->string x))) (case (string-width str) ((1) `((load-symbol ,str))) ((4) `(,@(dump-object str addr) (make-symbol))) (else (error "bad string width" str))))) ((keyword? x) `(,@(dump-object (keyword->symbol x) addr) (make-keyword))) ((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))))))) ((and (array? x) (symbol? (array-type x))) (let* ((type (dump-object (array-type x) addr)) (shape (dump-object (array-shape x) (addr+ addr type)))) `(,@type ,@shape ,@(align-code `(load-array ,(uniform-array->bytevector x)) (addr+ (addr+ addr type) shape) 8 4)))) (else (error "assemble: unrecognized object" x))))