diff --git a/module/Makefile.am b/module/Makefile.am index 71f3637c5..21d2f08b9 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -50,7 +50,6 @@ SOURCES = \ language/tree-il/cse.scm \ \ language/tree-il.scm \ - language/glil.scm \ language/assembly.scm \ $(TREE_IL_LANG_SOURCES) \ $(CPS_LANG_SOURCES) \ @@ -136,9 +135,6 @@ RTL_LANG_SOURCES = \ language/rtl.scm \ language/rtl/spec.scm -GLIL_LANG_SOURCES = \ - language/glil/spec.scm language/glil/compile-assembly.scm - ASSEMBLY_LANG_SOURCES = \ language/assembly/spec.scm \ language/assembly/compile-bytecode.scm \ diff --git a/module/language/glil.scm b/module/language/glil.scm deleted file mode 100644 index 9c238547d..000000000 --- a/module/language/glil.scm +++ /dev/null @@ -1,170 +0,0 @@ -;;; Guile Low Intermediate Language - -;; Copyright (C) 2001, 2009, 2010 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) - #:use-module (system base syntax) - #:use-module (system base pmatch) - #:use-module ((srfi srfi-1) #:select (fold)) - #:export - ( make-glil-program glil-program? - glil-program-meta glil-program-body - - make-glil-std-prelude glil-std-prelude? - glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label - - make-glil-opt-prelude glil-opt-prelude? - glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest - glil-opt-prelude-nlocs glil-opt-prelude-else-label - - make-glil-kw-prelude glil-kw-prelude? - glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw - glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest - glil-kw-prelude-nlocs glil-kw-prelude-else-label - - make-glil-bind glil-bind? - glil-bind-vars - - make-glil-mv-bind glil-mv-bind? - glil-mv-bind-vars glil-mv-bind-rest - - make-glil-unbind glil-unbind? - - make-glil-source glil-source? - glil-source-props - - make-glil-void glil-void? - - make-glil-const glil-const? - glil-const-obj - - make-glil-lexical glil-lexical? - glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index - - make-glil-toplevel glil-toplevel? - glil-toplevel-op glil-toplevel-name - - make-glil-module glil-module? - glil-module-op glil-module-mod glil-module-name glil-module-public? - - make-glil-label glil-label? - glil-label-label - - make-glil-branch glil-branch? - glil-branch-inst glil-branch-label - - make-glil-call glil-call? - glil-call-inst glil-call-nargs - - make-glil-mv-call glil-mv-call? - glil-mv-call-nargs glil-mv-call-ra - - make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only? - - parse-glil unparse-glil)) - -(define (print-glil x port) - (format port "#" (unparse-glil x))) - -(define-type ( #:printer print-glil) - ;; Meta operations - ( meta body) - ( nreq nlocs else-label) - ( nreq nopt rest nlocs else-label) - ( nreq nopt rest kw allow-other-keys? nlocs else-label) - ( vars) - ( vars rest) - () - ( props) - ;; Objects - () - ( obj) - ;; Variables - ( local? boxed? op index) - ( op name) - ( op mod name public?) - ;; Controls - ( label) - ( inst label) - ( inst nargs) - ( nargs ra) - ( label escape-only?)) - - - -(define (parse-glil x) - (pmatch x - ((program ,meta . ,body) - (make-glil-program meta (map parse-glil body))) - ((std-prelude ,nreq ,nlocs ,else-label) - (make-glil-std-prelude nreq nlocs else-label)) - ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label) - (make-glil-opt-prelude nreq nopt rest nlocs else-label)) - ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label) - (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label)) - ((bind . ,vars) (make-glil-bind vars)) - ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) - ((unbind) (make-glil-unbind)) - ((source ,props) (make-glil-source props)) - ((void) (make-glil-void)) - ((const ,obj) (make-glil-const obj)) - ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) - ((toplevel ,op ,name) (make-glil-toplevel op name)) - ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) - ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) - ((label ,label) (make-glil-label label)) - ((branch ,inst ,label) (make-glil-branch inst label)) - ((call ,inst ,nargs) (make-glil-call inst nargs)) - ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) - ((prompt ,label ,escape-only?) - (make-glil-prompt label escape-only?)) - (else (error "invalid glil" x)))) - -(define (unparse-glil glil) - (record-case glil - ;; meta - (( meta body) - `(program ,meta ,@(map unparse-glil body))) - (( nreq nlocs else-label) - `(std-prelude ,nreq ,nlocs ,else-label)) - (( nreq nopt rest nlocs else-label) - `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)) - (( nreq nopt rest kw allow-other-keys? nlocs else-label) - `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)) - (( vars) `(bind ,@vars)) - (( vars rest) `(mv-bind ,vars ,rest)) - (() `(unbind)) - (( props) `(source ,props)) - ;; constants - (() `(void)) - (( obj) `(const ,obj)) - ;; variables - (( local? boxed? op index) - `(lexical ,local? ,boxed? ,op ,index)) - (( op name) - `(toplevel ,op ,name)) - (( op mod name public?) - `(module ,(if public? 'public 'private) ,op ,mod ,name)) - ;; controls - (( label) `(label ,label)) - (( inst label) `(branch ,inst ,label)) - (( inst nargs) `(call ,inst ,nargs)) - (( nargs ra) `(mv-call ,nargs ,ra)) - (( label escape-only?) - `(prompt ,label escape-only?)))) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm deleted file mode 100644 index 463348504..000000000 --- a/module/language/glil/compile-assembly.scm +++ /dev/null @@ -1,952 +0,0 @@ -;;; Guile VM assembler - -;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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-assembly) - #: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 (ice-9 vlist) - #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module (rnrs bytevectors) - #:export (compile-assembly)) - -;; Traversal helpers -;; -(define (vhash-fold-right2 proc vhash s0 s1) - (let lp ((i (vlist-length vhash)) (s0 s0) (s1 s1)) - (if (zero? i) - (values s0 s1) - (receive (s0 s1) (let ((pair (vlist-ref vhash (1- i)))) - (proc (car pair) (cdr pair) s0 s1)) - (lp (1- i) s0 s1))))) - -(define (fold2 proc ls s0 s1) - (let lp ((ls ls) (s0 s0) (s1 s1)) - (if (null? ls) - (values s0 s1) - (receive (s0 s1) (proc (car ls) s0 s1) - (lp (cdr ls) s0 s1))))) - -(define (vector-fold2 proc vect s0 s1) - (let ((len (vector-length vect))) - (let lp ((i 0) (s0 s0) (s1 s1)) - (if (< i len) - (receive (s0 s1) (proc (vector-ref vect i) s0 s1) - (lp (1+ i) s0 s1)) - (values s0 s1))))) - -;; 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) - -(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))))))) - - -;; Avoid going through the compiler so as to avoid adding to the -;; constant store. -(define (make-meta bindings sources arities tail) - (let ((body `(,@(dump-object `(,bindings ,sources ,arities ,@tail) 0) - (return)))) - `(load-program () - ,(addr+ 0 body) - #f - ,@body))) - -;; If this is true, the object doesn't need to go in a constant table. -;; -(define (immediate? x) - (object->assembly x)) - -;; This tests for a proper scheme list whose last cdr is '(), not #nil. -;; -(define (scheme-list? x) - (and (list? x) - (or (eq? x '()) - (let ((p (last-pair x))) - (and (pair? p) - (eq? (cdr p) '())))))) - -;; Note: in all of these procedures that build up constant tables, the -;; first (zeroth) index is reserved. At runtime it is replaced with the -;; procedure's module. Hence all of this 1+ length business. - -;; Build up a vhash of constant -> index, allowing us to build up a -;; constant table for a whole compilation unit. -;; -(define (build-constant-store x) - (define (add-to-store store x) - (define (add-to-end store x) - (vhash-cons x (1+ (vlist-length store)) store)) - (cond - ((vhash-assoc x store) - ;; Already in the store. - store) - ((immediate? x) - ;; Immediates don't need to go in the constant table. - store) - ((or (number? x) - (string? x) - (symbol? x) - (keyword? x)) - ;; Atoms. - (add-to-end store x)) - ((variable-cache-cell? x) - ;; Variable cache cells (see below). - (add-to-end (add-to-store store (variable-cache-cell-key x)) - x)) - ((list? x) - ;; Add the elements to the store, then the list itself. We could - ;; try hashing the cdrs as well, but that seems a bit overkill, and - ;; this way we do compress the bytecode a bit by allowing the use of - ;; the `list' opcode. - (let ((store (fold (lambda (x store) - (add-to-store store x)) - store - x))) - (add-to-end store x))) - ((pair? x) - ;; Non-lists get caching on both fields. - (let ((store (add-to-store (add-to-store store (car x)) - (cdr x)))) - (add-to-end store x))) - ((and (vector? x) - (equal? (array-shape x) (list (list 0 (1- (vector-length x)))))) - ;; Likewise, add the elements to the store, then the vector itself. - ;; Important for the vectors produced by the psyntax expansion - ;; process. - (let ((store (fold (lambda (x store) - (add-to-store store x)) - store - (vector->list x)))) - (add-to-end store x))) - ((array? x) - ;; Naive assumption that if folks are using arrays, that perhaps - ;; there's not much more duplication. - (add-to-end store x)) - (else - (error "build-constant-store: unrecognized object" x)))) - - (let walk ((x x) (store vlist-null)) - (record-case x - (( meta body) - (fold walk store body)) - (( obj) - (add-to-store store obj)) - (( kw) - (add-to-store store kw)) - (( op name) - ;; We don't add toplevel variable cache cells to the global - ;; constant table, because they are sensitive to changes in - ;; modules as the toplevel expressions are evaluated. So we just - ;; add the name. - (add-to-store store name)) - (( op mod name public?) - ;; However, it is fine add module variable cache cells to the - ;; global table, as their bindings are not dependent on the - ;; current module. - (add-to-store store - (make-variable-cache-cell (list mod name public?)))) - (else store)))) - -;; Analyze one to determine its object table. Produces a -;; vhash of constant to index. -;; -(define (build-object-table x) - (define (add store x) - (if (vhash-assoc x store) - store - (vhash-cons x (1+ (vlist-length store)) store))) - (record-case x - (( meta body) - (fold (lambda (x table) - (record-case x - (( meta body) - ;; Add the GLIL itself to the table. - (add table x)) - (( obj) - (if (immediate? obj) - table - (add table obj))) - (( kw) - (add table kw)) - (( op name) - (add table (make-variable-cache-cell name))) - (( op mod name public?) - (add table (make-variable-cache-cell (list mod name public?)))) - (else table))) - vlist-null - body)))) - -;; 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 arities thingamajiggy. -;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...) -(define (open-arity addr nreq nopt rest kw arities) - (cons - (cond - (kw (list addr nreq nopt rest kw)) - (rest (list addr nreq nopt rest)) - (nopt (list addr nreq nopt)) - (nreq (list addr nreq)) - (else (list addr))) - arities)) -(define (close-arity addr arities) - (pmatch arities - (() '()) - (((,start . ,tail) . ,rest) - `((,start ,addr . ,tail) . ,rest)) - (else (error "bad arities" arities)))) -(define (begin-arity end start nreq nopt rest kw arities) - (open-arity start nreq nopt rest kw (close-arity end arities))) - -(define (compile-assembly glil) - (let* ((all-constants (build-constant-store glil)) - (prog (compile-program glil all-constants)) - (len (byte-length prog))) - ;; The top objcode thunk. We're going to wrap this thunk in - ;; a thunk -- yo dawgs -- with the goal being to lift all - ;; constants up to the top level. The store forms a DAG, so - ;; we can actually build up later elements in terms of - ;; earlier ones. - ;; - (cond - ((vlist-null? all-constants) - ;; No constants: just emit the inner thunk. - prog) - (else - ;; We have an object store, so write it out, attach it - ;; to the inner thunk, and tail call. - (receive (tablecode addr) (dump-constants all-constants) - (let ((prog (align-program prog addr))) - ;; Outer thunk. - `(load-program () - ,(+ (addr+ addr prog) - 2 ; for (tail-call 0) - ) - #f - ;; Load the table, build the inner - ;; thunk, then tail call. - ,@tablecode - ,@prog - (tail-call 0)))))))) - -(define (compile-program glil constants) - (record-case glil - (( meta body) - (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) - (label-alist '()) (arities '()) (addr 0)) - (cond - ((null? body) - (let ((code (fold append '() code)) - (bindings (close-all-bindings bindings addr)) - (sources (limn-sources (reverse! source-alist))) - (labels (reverse label-alist)) - (arities (reverse (close-arity addr arities))) - (len addr)) - (let* ((meta (make-meta bindings sources arities meta)) - (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))) - `(load-program ,labels - ,(+ len meta-pad) - ,meta - ,@code - ,@(if meta - (make-list meta-pad '(nop)) - '()))))) - (else - (receive (subcode bindings source-alist label-alist arities) - (glil->assembly (car body) bindings - source-alist label-alist - constants arities addr) - (lp (cdr body) (cons subcode code) - bindings source-alist label-alist arities - (addr+ addr subcode))))))))) - -(define (compile-objtable constants table addr) - (define (load-constant idx) - (if (< idx 256) - (values `((object-ref ,idx)) - 2) - (values `((long-object-ref - ,(quotient idx 256) ,(modulo idx 256))) - 3))) - (cond - ((vlist-null? table) - ;; Empty table; just return #f. - (values '((make-false)) - (1+ addr))) - (else - (call-with-values - (lambda () - (vhash-fold-right2 - (lambda (obj idx codes addr) - (cond - ((vhash-assoc obj constants) - => (lambda (pair) - (receive (load len) (load-constant (cdr pair)) - (values (cons load codes) - (+ addr len))))) - ((variable-cache-cell? obj) - (cond - ((vhash-assoc (variable-cache-cell-key obj) constants) - => (lambda (pair) - (receive (load len) (load-constant (cdr pair)) - (values (cons load codes) - (+ addr len))))) - (else (error "vcache cell key not in table" obj)))) - ((glil-program? obj) - ;; Programs are not cached in the global constants - ;; table because when a program is loaded, its module - ;; is bound, and we want to do that only after any - ;; preceding effectful statements. - (let* ((table (build-object-table obj)) - (prog (compile-program obj table))) - (receive (tablecode addr) - (compile-objtable constants table addr) - (let ((prog (align-program prog addr))) - (values (cons `(,@tablecode ,@prog) - codes) - (addr+ addr prog)))))) - (else - (error "unrecognized constant" obj)))) - table - '(((make-false))) (1+ addr))) - (lambda (elts addr) - (let ((len (1+ (vlist-length table)))) - (values - (fold append - `((vector ,(quotient len 256) ,(modulo len 256))) - elts) - (+ addr 3)))))))) - -(define (glil->assembly glil bindings source-alist label-alist - constants arities addr) - (define (emit-code x) - (values x bindings source-alist label-alist arities)) - (define (emit-object-ref i) - (values (if (< i 256) - `((object-ref ,i)) - `((long-object-ref ,(quotient i 256) ,(modulo i 256)))) - bindings source-alist label-alist arities)) - (define (emit-code/arity x nreq nopt rest kw) - (values x bindings source-alist label-alist - (begin-arity addr (addr+ addr x) nreq nopt rest kw arities))) - - (record-case glil - (( meta body) - (cond - ((vhash-assoc glil constants) - ;; We are cached in someone's objtable; just emit a load. - => (lambda (pair) - (emit-object-ref (cdr pair)))) - (else - ;; Otherwise, build an objtable for the program, compile it, and - ;; emit a load-program. - (let* ((table (build-object-table glil)) - (prog (compile-program glil table))) - (receive (tablecode addr) (compile-objtable constants table addr) - (emit-code `(,@tablecode ,@(align-program prog addr)))))))) - - (( nreq nlocs else-label) - (emit-code/arity - (if (and (< nreq 8) (< nlocs (+ nreq 32)) (not else-label)) - `((assert-nargs-ee/locals ,(logior nreq (ash (- nlocs nreq) 3)))) - `(,(if else-label - `(br-if-nargs-ne ,(quotient nreq 256) - ,(modulo nreq 256) - ,else-label) - `(assert-nargs-ee ,(quotient nreq 256) - ,(modulo nreq 256))) - (reserve-locals ,(quotient nlocs 256) - ,(modulo nlocs 256)))) - nreq #f #f #f)) - - (( nreq nopt rest nlocs else-label) - (let ((bind-required - (if else-label - `((br-if-nargs-lt ,(quotient nreq 256) - ,(modulo nreq 256) - ,else-label)) - `((assert-nargs-ge ,(quotient nreq 256) - ,(modulo nreq 256))))) - (bind-optionals - (if (zero? nopt) - '() - `((bind-optionals ,(quotient (+ nopt nreq) 256) - ,(modulo (+ nreq nopt) 256))))) - (bind-rest - (cond - (rest - `((push-rest ,(quotient (+ nreq nopt) 256) - ,(modulo (+ nreq nopt) 256)))) - (else - (if else-label - `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256) - ,(modulo (+ nreq nopt) 256) - ,else-label)) - `((assert-nargs-ee ,(quotient (+ nreq nopt) 256) - ,(modulo (+ nreq nopt) 256)))))))) - (emit-code/arity - `(,@bind-required - ,@bind-optionals - ,@bind-rest - (reserve-locals ,(quotient nlocs 256) - ,(modulo nlocs 256))) - nreq nopt rest #f))) - - (( nreq nopt rest kw allow-other-keys? nlocs else-label) - (let* ((kw-idx (or (and=> (vhash-assoc kw constants) cdr) - (error "kw not in objtable"))) - (bind-required - (if else-label - `((br-if-nargs-lt ,(quotient nreq 256) - ,(modulo nreq 256) - ,else-label)) - `((assert-nargs-ge ,(quotient nreq 256) - ,(modulo nreq 256))))) - (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw)))) - (bind-optionals-and-shuffle - `((,(if (and else-label (not rest)) - 'bind-optionals/shuffle-or-br - 'bind-optionals/shuffle) - ,(quotient nreq 256) - ,(modulo nreq 256) - ,(quotient (+ nreq nopt) 256) - ,(modulo (+ nreq nopt) 256) - ,(quotient ntotal 256) - ,(modulo ntotal 256) - ,@(if (and else-label (not rest)) - `(,else-label) - '())))) - (bind-kw - ;; when this code gets called, all optionals are filled - ;; in, space has been made for kwargs, and the kwargs - ;; themselves have been shuffled above the slots for all - ;; req/opt/kwargs locals. - `((bind-kwargs - ,(quotient kw-idx 256) - ,(modulo kw-idx 256) - ,(quotient ntotal 256) - ,(modulo ntotal 256) - ,(logior (if rest 2 0) - (if allow-other-keys? 1 0))))) - (bind-rest - (if rest - `((bind-rest ,(quotient ntotal 256) - ,(modulo ntotal 256) - ,(quotient rest 256) - ,(modulo rest 256))) - '()))) - - (let ((code `(,@bind-required - ,@bind-optionals-and-shuffle - ,@bind-kw - ,@bind-rest - (reserve-locals ,(quotient nlocs 256) - ,(modulo nlocs 256))))) - (values code bindings source-alist label-alist - (begin-arity addr (addr+ addr code) nreq nopt rest - (and kw (cons allow-other-keys? kw)) - arities))))) - - (( vars) - (values '() - (open-binding bindings vars addr) - source-alist - label-alist - arities)) - - (( vars rest) - (if (integer? vars) - (values `((truncate-values ,vars ,(if rest 1 0))) - bindings - source-alist - label-alist - arities) - (values `((truncate-values ,(length vars) ,(if rest 1 0))) - (open-binding bindings vars addr) - source-alist - label-alist - arities))) - - (() - (values '() - (close-binding bindings addr) - source-alist - label-alist - arities)) - - (( props) - (values '() - bindings - (acons addr props source-alist) - label-alist - arities)) - - (() - (emit-code '((void)))) - - (( obj) - (cond - ((object->assembly obj) - => (lambda (code) - (emit-code (list code)))) - ((vhash-assoc obj constants) - => (lambda (pair) - (emit-object-ref (cdr pair)))) - (else (error "const not in table" obj)))) - - (( 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))) - ((bound?) (if boxed? - `((local-ref ,index) - (variable-bound?)) - `((local-bound? ,index)))) - (else (error "what" op))) - (let ((a (quotient index 256)) - (b (modulo index 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))) - ((bound?) - (if boxed? - `((long-local-ref ,a ,b) - (variable-bound?)) - `((long-local-bound? ,a ,b)))) - (else (error "what" op))))) - `((,(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 - ((and=> (vhash-assoc (make-variable-cache-cell name) constants) - cdr) - => (lambda (i) - (emit-code (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))))))) - (else - (let ((i (or (and=> (vhash-assoc name constants) cdr) - (error "toplevel name not in objtable" name)))) - (emit-code `(,(if (< i 256) - `(object-ref ,i) - `(long-object-ref ,(quotient i 256) - ,(modulo i 256))) - (link-now) - ,(case op - ((ref) '(variable-ref)) - ((set) '(variable-set))))))))) - ((define) - (let ((i (or (and=> (vhash-assoc name constants) cdr) - (error "toplevel name not in objtable" name)))) - (emit-code `(,(if (< i 256) - `(object-ref ,i) - `(long-object-ref ,(quotient i 256) - ,(modulo i 256))) - (define))))) - (else - (error "unknown toplevel var kind" op name)))) - - (( op mod name public?) - (let ((key (list mod name public?))) - (case op - ((ref set) - (let ((i (or (and=> (vhash-assoc (make-variable-cache-cell key) - constants) cdr) - (error "module vcache not in objtable" key)))) - (emit-code (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))))))) - (else - (error "unknown module var kind" op key))))) - - (( label) - (let ((code (align-block addr))) - (values code - bindings - source-alist - (acons label (addr+ addr code) label-alist) - arities))) - - (( inst label) - (emit-code `((,inst ,label)))) - - ;; nargs is number of stack args to insn. probably should rename. - (( inst nargs) - (if (not (instruction? inst)) - (error "Unknown instruction:" inst)) - (let ((pops (instruction-pops inst))) - (cond ((< pops 0) - (case (instruction-length inst) - ((1) (emit-code `((,inst ,nargs)))) - ((2) (emit-code `((,inst ,(quotient nargs 256) - ,(modulo nargs 256))))) - (else (error "Unknown length for variable-arg instruction:" - inst (instruction-length inst))))) - ((= pops nargs) - (emit-code `((,inst)))) - (else - (error "Wrong number of stack arguments to instruction:" inst nargs))))) - - (( nargs ra) - (emit-code `((mv-call ,nargs ,ra)))) - - (( label escape-only?) - (emit-code `((prompt ,(if escape-only? 1 0) ,label)))))) - -(define (dump-object x addr) - (define (too-long x) - (error (string-append x " too long"))) - - (cond - ((object->assembly x) => list) - ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) - ((number? x) - `((load-number ,(number->string x)))) - ((string? x) - (case (string-bytes-per-char x) - ((1) `((load-string ,x))) - ((4) (align-code `(load-wide-string ,x) addr 4 4)) - (else (error "bad string bytes per char" x)))) - ((symbol? x) - (let ((str (symbol->string x))) - (case (string-bytes-per-char str) - ((1) `((load-symbol ,str))) - ((4) `(,@(dump-object str addr) - (make-symbol))) - (else (error "bad string bytes per char" str))))) - ((keyword? x) - `(,@(dump-object (keyword->symbol x) addr) - (make-keyword))) - ((scheme-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)))) - ((and (vector? x) - (equal? (array-shape x) (list (list 0 (1- (vector-length 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)))) - ((array? x) - ;; an array of generic scheme values - (let* ((contents (array-contents x)) - (len (vector-length contents))) - (let dump-objects ((i 0) (codes '()) (addr addr)) - (if (< i len) - (let ((code (dump-object (vector-ref contents i) addr))) - (dump-objects (1+ i) (cons code codes) - (addr+ addr code))) - (fold append - `(,@(dump-object (array-shape x) addr) - (make-array ,(quotient (ash len -16) 256) - ,(logand #xff (ash len -8)) - ,(logand #xff len))) - codes))))) - (else - (error "dump-object: unrecognized object" x)))) - -(define (dump-constants constants) - (define (ref-or-dump x i addr) - (let ((pair (vhash-assoc x constants))) - (if (and pair (< (cdr pair) i)) - (let ((idx (cdr pair))) - (if (< idx 256) - (values `((object-ref ,idx)) - (+ addr 2)) - (values `((long-object-ref ,(quotient idx 256) - ,(modulo idx 256))) - (+ addr 3)))) - (dump1 x i addr)))) - (define (dump1 x i addr) - (cond - ((object->assembly x) - => (lambda (code) - (values (list code) - (+ (byte-length code) addr)))) - ((or (number? x) - (string? x) - (symbol? x) - (keyword? x)) - ;; Atoms. - (let ((code (dump-object x addr))) - (values code (addr+ addr code)))) - ((variable-cache-cell? x) - (dump1 (variable-cache-cell-key x) i addr)) - ((scheme-list? x) - (receive (codes addr) - (fold2 (lambda (x codes addr) - (receive (subcode addr) (ref-or-dump x i addr) - (values (cons subcode codes) addr))) - x '() addr) - (values (fold append - (let ((len (length x))) - `((list ,(quotient len 256) ,(modulo len 256)))) - codes) - (+ addr 3)))) - ((pair? x) - (receive (car-code addr) (ref-or-dump (car x) i addr) - (receive (cdr-code addr) (ref-or-dump (cdr x) i addr) - (values `(,@car-code ,@cdr-code (cons)) - (1+ addr))))) - ((and (vector? x) - (<= (vector-length x) #xffff) - (equal? (array-shape x) (list (list 0 (1- (vector-length x)))))) - (receive (codes addr) - (vector-fold2 (lambda (x codes addr) - (receive (subcode addr) (ref-or-dump x i addr) - (values (cons subcode codes) addr))) - x '() addr) - (values (fold append - (let ((len (vector-length x))) - `((vector ,(quotient len 256) ,(modulo len 256)))) - codes) - (+ addr 3)))) - ((and (array? x) (symbol? (array-type x))) - (receive (type addr) (ref-or-dump (array-type x) i addr) - (receive (shape addr) (ref-or-dump (array-shape x) i addr) - (let ((bv (align-code `(load-array ,(uniform-array->bytevector x)) - addr 8 4))) - (values `(,@type ,@shape ,@bv) - (addr+ addr bv)))))) - ((array? x) - (let ((contents (array-contents x))) - (receive (codes addr) - (vector-fold2 (lambda (x codes addr) - (receive (subcode addr) (ref-or-dump x i addr) - (values (cons subcode codes) addr))) - contents '() addr) - (receive (shape addr) (ref-or-dump (array-shape x) i addr) - (values (fold append - (let ((len (vector-length contents))) - `(,@shape - (make-array ,(quotient (ash len -16) 256) - ,(logand #xff (ash len -8)) - ,(logand #xff len)))) - codes) - (+ addr 4)))))) - (else - (error "write-table: unrecognized object" x)))) - - (receive (codes addr) - (vhash-fold-right2 (lambda (obj idx code addr) - ;; The vector is on the stack. Dup it, push - ;; the index, push the val, then vector-set. - (let ((pre `((dup) - ,(object->assembly idx)))) - (receive (valcode addr) (dump1 obj idx - (addr+ addr pre)) - (values (cons* '((vector-set)) - valcode - pre - code) - (1+ addr))))) - constants - '(((assert-nargs-ee/locals 1) - ;; Push the vector. - (local-ref 0))) - 4) - (let* ((len (1+ (vlist-length constants))) - (pre-prog-addr (+ 2 ; reserve-locals - len 3 ; empty vector - 2 ; local-set - 1 ; new-frame - 2 ; local-ref - )) - (prog (align-program - `(load-program () - ,(+ addr 1) - #f - ;; The `return' will be at the tail of the - ;; program. The vector is already pushed - ;; on the stack. - . ,(fold append '((return)) codes)) - pre-prog-addr))) - (values `(;; Reserve storage for the vector. - (assert-nargs-ee/locals ,(logior 0 (ash 1 3))) - ;; Push the vector, and store it in slot 0. - ,@(make-list len '(make-false)) - (vector ,(quotient len 256) ,(modulo len 256)) - (local-set 0) - ;; Now we open the call frame. - ;; - (new-frame) - ;; Now build a thunk to init the constants. It will - ;; have the unfinished constant table both as its - ;; argument and as its objtable. The former allows it - ;; to update the objtable, with vector-set!, and the - ;; latter allows init code to refer to previously set - ;; values. - ;; - ;; Grab the vector, to be the objtable. - (local-ref 0) - ;; Now the load-program, properly aligned. Pops the vector. - ,@prog - ;; Grab the vector, as an argument this time. - (local-ref 0) - ;; Call the init thunk with the vector as an arg. - (call 1) - ;; The thunk also returns the vector. Leave it on the - ;; stack for compile-assembly to use. - ) - ;; The byte length of the init code, which we can - ;; determine without folding over the code again. - (+ (addr+ pre-prog-addr prog) ; aligned program - 2 ; local-ref - 2 ; call - ))))) diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm deleted file mode 100644 index 81e06af5d..000000000 --- a/module/language/glil/spec.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Guile Lowlevel Intermediate Language - -;; Copyright (C) 2001, 2009, 2010, 2013 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 spec) - #:use-module (system base language) - #:use-module (language glil) - #:use-module (language glil compile-assembly) - #:export (glil)) - -(define (write-glil exp . port) - (apply write (unparse-glil exp) port)) - -(define (compile-asm x e opts) - (values (compile-assembly x) e e)) - -(define-language glil - #:title "Guile Lowlevel Intermediate Language (GLIL)" - #:reader (lambda (port env) (read port)) - #:printer write-glil - #:parser parse-glil - #:compilers `((assembly . ,compile-asm)) - #:for-humans? #f - )