From 51b91fe14159b539f19812e8af8ec5ca7ab2e97d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 14 Aug 2009 13:44:16 +0200 Subject: temp commit --- module/Makefile.am | 4 +- module/language/glil/compile-sassy.scm | 478 +++++++++++++++++++++++++++++++++ module/language/glil/spec.scm | 7 +- module/language/sassy/spec.scm | 34 +++ 4 files changed, 520 insertions(+), 3 deletions(-) create mode 100644 module/language/glil/compile-sassy.scm create mode 100644 module/language/sassy/spec.scm diff --git a/module/Makefile.am b/module/Makefile.am index f5c264bef..123087845 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -89,7 +89,9 @@ GHIL_LANG_SOURCES = \ language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm GLIL_LANG_SOURCES = \ - language/glil/spec.scm language/glil/compile-assembly.scm \ + language/glil/compile-assembly.scm \ + language/glil/spec.scm \ + language/glil/compile-sassy.scm \ language/glil/decompile-assembly.scm ASSEMBLY_LANG_SOURCES = \ diff --git a/module/language/glil/compile-sassy.scm b/module/language/glil/compile-sassy.scm new file mode 100644 index 000000000..1ce561eb0 --- /dev/null +++ b/module/language/glil/compile-sassy.scm @@ -0,0 +1,478 @@ +;;; 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)))) + diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index d5291a211..3b7e9700a 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -1,6 +1,6 @@ ;;; Guile Lowlevel Intermediate Language -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; 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 @@ -23,6 +23,7 @@ #:use-module (language glil) #:use-module (language glil compile-assembly) #:use-module (language glil decompile-assembly) + #:use-module (language glil compile-sassy) #:export (glil)) (define (write-glil exp . port) @@ -37,5 +38,7 @@ #:reader read #:printer write-glil #:parser parse-glil - #:compilers `((assembly . ,compile-asm)) + #:compilers `((assembly . ,compile-asm) + (sassy . ,(lambda x e opts) + (values (compile-sassy x) e e))) #:decompilers `((assembly . ,decompile-assembly))) diff --git a/module/language/sassy/spec.scm b/module/language/sassy/spec.scm new file mode 100644 index 000000000..65d4a261f --- /dev/null +++ b/module/language/sassy/spec.scm @@ -0,0 +1,34 @@ +;;; Guile x86-32 Machine Assembly + +;; Copyright (C) 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 sassy spec) + #:use-module (system base language) + ; #:use-module (language sassy compile-elf) + #:export (assembly)) + +(define-language sassy + #:title "Guile x86-32 Assembly Language" + #:version "2.0" + #:reader read + #:printer write + #:parser read +; #:compilers `((bytecode . ,compile-bytecode)) +; #:decompilers `((bytecode . ,decompile-bytecode)) + ) -- cgit v1.2.1