mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-02 15:40:38 +02:00
07b820a804
* libguile/vm-i-scheme.c (array-contents): New VM instruction. * module/language/glil/compile-assembly.scm (vhash-fold-right3, fold3, fold2-3): New procedures. (add-to-store): Accept new argument 'ancestors'. Use it to prevent infinite loops. Augment it when traversing into lists, pairs, vectors, or arrays. (build-constant-store): Adapt to new argument to 'add-to-store'. (ref-or-dump): Accept new arguments 'post' and 'f'. If the referenced object has not yet been serialized, augment 'post' to add code that will mutate it to the correct value after all initializations. (dump1): Accept new argument 'post'. Return a third value: the new 'post'. Pass new arguments to 'ref-or-dump'. (dump-constants): Adapt to new argument and return value of 'dump1'. Apply post-procs to mutate fields of constants as needed to handle cyclic data.
1070 lines
42 KiB
Scheme
1070 lines
42 KiB
Scheme
;;; Guile VM assembler
|
|
|
|
;; Copyright (C) 2001, 2009, 2010, 2011, 2013,
|
|
;; 2014 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 (vhash-fold-right3 proc vhash s0 s1 s2)
|
|
(let lp ((i (vlist-length vhash)) (s0 s0) (s1 s1) (s2 s2))
|
|
(if (zero? i)
|
|
(values s0 s1 s2)
|
|
(receive (s0 s1 s2) (let ((pair (vlist-ref vhash (1- i))))
|
|
(proc (car pair) (cdr pair) s0 s1 s2))
|
|
(lp (1- i) s0 s1 s2)))))
|
|
|
|
(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 (fold3 proc ls s0 s1 s2)
|
|
(let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2))
|
|
(if (null? ls)
|
|
(values s0 s1 s2)
|
|
(receive (s0 s1 s2) (proc (car ls) s0 s1 s2)
|
|
(lp (cdr ls) s0 s1 s2)))))
|
|
|
|
(define (fold2-3 proc ls1 ls2 s0 s1 s2)
|
|
(let lp ((ls1 ls1) (ls2 ls2) (s0 s0) (s1 s1) (s2 s2))
|
|
(if (null? ls1)
|
|
(values s0 s1 s2)
|
|
(receive (s0 s1 s2) (proc (car ls1) (car ls2) s0 s1 s2)
|
|
(lp (cdr ls1) (cdr ls2) s0 s1 s2)))))
|
|
|
|
(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 <variable-cache-cell> 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 ancestors x)
|
|
(define (add-ancestor ancestors x)
|
|
(vhash-cons x #t ancestors))
|
|
(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)
|
|
((vhash-assoc x ancestors)
|
|
;; Break the cycle.
|
|
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 ancestors (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 ((ancestors (add-ancestor ancestors x)))
|
|
(let ((store (fold (lambda (x store)
|
|
(add-to-store store ancestors x))
|
|
store
|
|
x)))
|
|
(add-to-end store x))))
|
|
((pair? x)
|
|
;; Non-lists get caching on both fields.
|
|
(let ((ancestors (add-ancestor ancestors x)))
|
|
(let ((store (add-to-store (add-to-store store ancestors (car x))
|
|
ancestors
|
|
(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 ((ancestors (add-ancestor ancestors x)))
|
|
(let ((store (fold (lambda (x store)
|
|
(add-to-store store ancestors 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
|
|
((<glil-program> meta body)
|
|
(fold walk store body))
|
|
((<glil-const> obj)
|
|
(add-to-store store vlist-null obj))
|
|
((<glil-kw-prelude> kw)
|
|
(add-to-store store vlist-null kw))
|
|
((<glil-toplevel> 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 vlist-null name))
|
|
((<glil-module> 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 vlist-null
|
|
(make-variable-cache-cell (list mod name public?))))
|
|
(else store))))
|
|
|
|
;; Analyze one <glil-program> 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
|
|
((<glil-program> meta body)
|
|
(fold (lambda (x table)
|
|
(record-case x
|
|
((<glil-program> meta body)
|
|
;; Add the GLIL itself to the table.
|
|
(add table x))
|
|
((<glil-const> obj)
|
|
(if (immediate? obj)
|
|
table
|
|
(add table obj)))
|
|
((<glil-kw-prelude> kw)
|
|
(add table kw))
|
|
((<glil-toplevel> op name)
|
|
(add table (make-variable-cache-cell name)))
|
|
((<glil-module> 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
|
|
((<glil-program> 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
|
|
((<glil-program> 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))))))))
|
|
|
|
((<glil-std-prelude> 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))
|
|
|
|
((<glil-opt-prelude> 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)))
|
|
|
|
((<glil-kw-prelude> 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)))))
|
|
|
|
((<glil-bind> vars)
|
|
(values '()
|
|
(open-binding bindings vars addr)
|
|
source-alist
|
|
label-alist
|
|
arities))
|
|
|
|
((<glil-mv-bind> 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)))
|
|
|
|
((<glil-unbind>)
|
|
(values '()
|
|
(close-binding bindings addr)
|
|
source-alist
|
|
label-alist
|
|
arities))
|
|
|
|
((<glil-source> props)
|
|
(values '()
|
|
bindings
|
|
(acons addr props source-alist)
|
|
label-alist
|
|
arities))
|
|
|
|
((<glil-void>)
|
|
(emit-code '((void))))
|
|
|
|
((<glil-const> 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))))
|
|
|
|
((<glil-lexical> 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)))))
|
|
|
|
((<glil-toplevel> 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))))
|
|
|
|
((<glil-module> 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)))))
|
|
|
|
((<glil-label> label)
|
|
(let ((code (align-block addr)))
|
|
(values code
|
|
bindings
|
|
source-alist
|
|
(acons label (addr+ addr code) label-alist)
|
|
arities)))
|
|
|
|
((<glil-branch> inst label)
|
|
(emit-code `((,inst ,label))))
|
|
|
|
;; nargs is number of stack args to insn. probably should rename.
|
|
((<glil-call> 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)))))
|
|
|
|
((<glil-mv-call> nargs ra)
|
|
(emit-code `((mv-call ,nargs ,ra))))
|
|
|
|
((<glil-prompt> 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 post f)
|
|
(let ((pair (vhash-assoc x constants)))
|
|
(cond
|
|
((and pair (< (cdr pair) i))
|
|
(let ((idx (cdr pair)))
|
|
(if (< idx 256)
|
|
(values `((object-ref ,idx))
|
|
(+ addr 2)
|
|
post)
|
|
(values `((long-object-ref ,(quotient idx 256)
|
|
,(modulo idx 256)))
|
|
(+ addr 3)
|
|
post))))
|
|
((and pair f)
|
|
(let ((idx (cdr pair)))
|
|
(values '((void))
|
|
(+ addr 1)
|
|
(cons (f (lambda (addr)
|
|
(if (< idx 256)
|
|
(values `((object-ref ,idx))
|
|
(+ addr 2))
|
|
(values `((long-object-ref ,(quotient idx 256)
|
|
,(modulo idx 256)))
|
|
(+ addr 3)))))
|
|
post))))
|
|
(else
|
|
(dump1 x i addr post)))))
|
|
(define (dump1 x i addr post)
|
|
(cond
|
|
((object->assembly x)
|
|
=> (lambda (code)
|
|
(values (list code)
|
|
(+ (byte-length code) addr)
|
|
post)))
|
|
((or (number? x)
|
|
(string? x)
|
|
(symbol? x)
|
|
(keyword? x))
|
|
;; Atoms.
|
|
(let ((code (dump-object x addr)))
|
|
(values code (addr+ addr code) post)))
|
|
((variable-cache-cell? x)
|
|
(dump1 (variable-cache-cell-key x) i addr post))
|
|
((scheme-list? x)
|
|
(let ((len (length x)))
|
|
(define (make-post-proc idx)
|
|
(lambda (get-val)
|
|
(lambda (addr)
|
|
(receive (get-list-code addr _) (ref-or-dump x (+ i 1) addr '() #f)
|
|
(receive (get-val-code addr) (get-val (+ addr idx))
|
|
(values `(,@get-list-code
|
|
,@(make-list idx '(cdr)) ; XXX sometimes make a loop, or combine?
|
|
,@get-val-code
|
|
(set-car!))
|
|
(+ addr 1)))))))
|
|
(receive (codes addr post)
|
|
(fold2-3 (lambda (x idx codes addr post)
|
|
(receive (subcode addr post)
|
|
(ref-or-dump x i addr post
|
|
(make-post-proc idx))
|
|
(values (cons subcode codes) addr post)))
|
|
x (iota len) '() addr post)
|
|
(values (fold append
|
|
`((list ,(quotient len 256) ,(modulo len 256)))
|
|
codes)
|
|
(+ addr 3)
|
|
post))))
|
|
((pair? x)
|
|
(let ()
|
|
(define (make-post-proc set-cxr!)
|
|
(lambda (get-val)
|
|
(lambda (addr)
|
|
(receive (get-pair-code addr _) (ref-or-dump x (+ i 1) addr '() #f)
|
|
(receive (get-val-code addr) (get-val addr)
|
|
(values `(,@get-pair-code
|
|
,@get-val-code
|
|
(,set-cxr!))
|
|
(+ addr 1)))))))
|
|
(receive (car-code addr post)
|
|
(ref-or-dump (car x) i addr post
|
|
(make-post-proc 'set-car!))
|
|
(receive (cdr-code addr post)
|
|
(ref-or-dump (cdr x) i addr post
|
|
(make-post-proc 'set-cdr!))
|
|
(values `(,@car-code ,@cdr-code (cons))
|
|
(1+ addr)
|
|
post)))))
|
|
((and (vector? x)
|
|
(<= (vector-length x) #xffff)
|
|
(equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
|
|
(let ((len (vector-length x)))
|
|
(define (make-post-proc idx)
|
|
(lambda (get-val)
|
|
(lambda (addr)
|
|
(receive (get-vect-code addr _) (ref-or-dump x (+ i 1) addr '() #f)
|
|
(let ((get-idx-code (object->assembly idx)))
|
|
(receive (get-val-code addr) (get-val (+ addr (byte-length get-idx-code)))
|
|
(values `(,@get-vect-code
|
|
,get-idx-code
|
|
,@get-val-code
|
|
(vector-set))
|
|
(+ addr 1))))))))
|
|
(receive (codes addr post)
|
|
(fold3 (lambda (idx codes addr post)
|
|
(receive (subcode addr post)
|
|
(ref-or-dump (vector-ref x idx) i addr post
|
|
(make-post-proc idx))
|
|
(values (cons subcode codes) addr post)))
|
|
(iota len) '() addr post)
|
|
(values (fold append
|
|
`((vector ,(quotient len 256) ,(modulo len 256)))
|
|
codes)
|
|
(+ addr 3)
|
|
post))))
|
|
((and (array? x) (symbol? (array-type x)))
|
|
(receive (type addr post) (ref-or-dump (array-type x) i addr post #f)
|
|
(receive (shape addr post) (ref-or-dump (array-shape x) i addr post #f)
|
|
(let ((bv (align-code `(load-array ,(uniform-array->bytevector x))
|
|
addr 8 4)))
|
|
(values `(,@type ,@shape ,@bv)
|
|
(addr+ addr bv)
|
|
post)))))
|
|
((array? x)
|
|
(let* ((contents (array-contents x))
|
|
(len (vector-length contents)))
|
|
(define (make-post-proc idx)
|
|
(lambda (get-val)
|
|
(lambda (addr)
|
|
(receive (get-array-code addr _)
|
|
(ref-or-dump x (+ i 1) addr '() #f)
|
|
(let ((get-idx-code (object->assembly idx)))
|
|
(receive (get-val-code addr)
|
|
(get-val (+ addr 1 (byte-length get-idx-code)))
|
|
(values `(,@get-array-code
|
|
(array-contents)
|
|
,get-idx-code
|
|
,@get-val-code
|
|
(vector-set))
|
|
(+ addr 1))))))))
|
|
(receive (codes addr post)
|
|
(fold3 (lambda (idx codes addr post)
|
|
(receive (subcode addr post)
|
|
(ref-or-dump (vector-ref contents idx) i addr post
|
|
(make-post-proc idx))
|
|
(values (cons subcode codes) addr post)))
|
|
(iota len) '() addr post)
|
|
(receive (shape addr post) (ref-or-dump (array-shape x) i addr post #f)
|
|
(values (fold append
|
|
`(,@shape
|
|
(make-array ,(quotient (ash len -16) 256)
|
|
,(logand #xff (ash len -8))
|
|
,(logand #xff len)))
|
|
codes)
|
|
(+ addr 4)
|
|
post)))))
|
|
(else
|
|
(error "write-table: unrecognized object" x))))
|
|
|
|
(receive (codes addr)
|
|
(receive (codes addr post)
|
|
(vhash-fold-right3 (lambda (obj idx code addr post)
|
|
;; 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 post)
|
|
(dump1 obj idx (addr+ addr pre) post)
|
|
(values (cons* '((vector-set))
|
|
valcode
|
|
pre
|
|
code)
|
|
(1+ addr)
|
|
post))))
|
|
constants
|
|
'(((assert-nargs-ee/locals 1)
|
|
;; Push the vector.
|
|
(local-ref 0)))
|
|
4
|
|
'())
|
|
;; Apply post-procs
|
|
(fold2 (lambda (post-proc codes addr)
|
|
(receive (subcode addr) (post-proc addr)
|
|
(values (cons subcode codes)
|
|
addr)))
|
|
post codes addr))
|
|
(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
|
|
)))))
|