[bpt/guile.git] / module / language / glil / compile-assembly.scm

;;; Guile VM 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-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 ((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 <variable-cache-cell> 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 <subprogram> 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-assembly
       (make-glil-program 0 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 (compile-assembly glil)
  (receive (code . _)
      (glil->assembly glil '() '(()) '() '() #f -1)
    (car code)))
(define (make-object-table objects)
  (and (not (null? objects))
       (list->vector (cons #f objects))))

(define (glil->assembly glil nexts-stack bindings
                        source-alist label-alist object-alist addr)
  (define (emit-code x)
    (values (map assembly-pack x) bindings source-alist label-alist object-alist))
  (define (emit-code/object x object-alist)
    (values (map assembly-pack x) bindings source-alist label-alist object-alist))

  (record-case glil
    ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
     (let ((toplevel? (null? nexts-stack)))
       (define (process-body)
         (let ((nexts-stack (cons nexts nexts-stack)))
           (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
                    (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
             (cond
              ((null? body)
               (values (reverse code)
                       (close-all-bindings bindings addr)
                       (limn-sources (reverse! source-alist))
                       (reverse label-alist)
                       (and object-alist (map car (reverse object-alist)))
                       addr))
              (else
               (receive (subcode bindings source-alist label-alist object-alist)
                   (glil->assembly (car body) nexts-stack bindings
                                   source-alist label-alist object-alist addr)
                 (lp (cdr body) (append (reverse subcode) code)
                     bindings source-alist label-alist object-alist
                     (addr+ addr subcode))))))))

       (receive (code bindings sources labels objects len)
           (process-body)
         (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
                                    ,len
                                    ,(make-meta bindings sources meta)
                                    . ,code)))
           (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 (align-program prog addr)))
            (else
             (let ((table (dump-object (make-object-table objects) addr))
                   (closure (if (> closure-level 0) '((make-closure)) '())))
               (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)))
                                       ,@closure)
                                     object-alist)))
                (else
                 ;; otherwise emit a load directly
                 (emit-code `(,@table ,@(align-program prog (addr+ addr table))
                                      ,@closure)))))))))))
    
    ((<glil-bind> vars)
     (values '()
             (open-binding bindings vars addr)
             source-alist
             label-alist
             object-alist))

    ((<glil-mv-bind> vars rest)
     (values `((truncate-values ,(length vars) ,(if rest 1 0)))
             (open-binding bindings vars addr)
             source-alist
             label-alist
             object-alist))

    ((<glil-unbind>)
     (values '()
             (close-binding bindings addr)
             source-alist
             label-alist
             object-alist))
             
    ((<glil-source> props)
     (values '()
             bindings
             (acons addr props source-alist)
             label-alist
             object-alist))

    ((<glil-void>)
     (emit-code '((void))))

    ((<glil-const> 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)))))

    ((<glil-local> op index)
     (emit-code (if (eq? op 'ref)
                    `((local-ref ,index))
                    `((local-set ,index)))))

    ((<glil-external> op depth index)
     (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
                  (if (> d 0)
                      (lp (1- d) (+ n (car stack)) (cdr stack))
                      (if (eq? op 'ref)
                          `((external-ref ,(+ n index)))
                          `((external-set ,(+ n index))))))))

    ((<glil-lexical> local? boxed? op index)
     (emit-code
      `((,(if local?
              (case op
                ((ref) (if boxed? 'local-boxed-ref 'local-ref))
                ((set) (if boxed? 'local-boxed-set 'local-set))
                ((box) 'box)
                ((empty-box) 'empty-box)
                (else (error "what" op)))
              (case op
                ((ref) (if boxed? 'closure-boxed-ref 'closure-ref))
                ((set) (if boxed? 'closure-boxed-set (error "what." glil)))
                (else (error "what" op))))
         ,index))))
    
    ((<glil-toplevel> 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 `((define ,(symbol->string name))
                     (variable-set))))
       (else
        (error "unknown toplevel var kind" op name))))

    ((<glil-module> 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)))))

    ((<glil-label> label)
     (values '()
             bindings
             source-alist
             (acons label addr label-alist)
             object-alist))

    ((<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))))))

(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))
   ((subprogram? x)
    `(,@(subprogram-table x)
      ,@(align-program (subprogram-prog x)
                       (addr+ addr (subprogram-table x)))))
   ((number? x)
    `((load-number ,(number->string x))))
   ((string? x)
    `((load-string ,x)))
   ((symbol? x)
    `((load-symbol ,(symbol->string x))))
   ((keyword? x)
    `((load-keyword ,(symbol->string (keyword->symbol x)))))
   ((list? x)
    (let ((tail (let ((len (length x)))
                  (if (>= len 65536) (too-long "list"))
                  `((list ,(quotient len 256) ,(modulo len 256))))))
      (let dump-objects ((objects x) (codes '()) (addr addr))
        (if (null? objects)
            (fold append tail codes)
            (let ((code (dump-object (car objects) addr)))
              (dump-objects (cdr objects) (cons code codes)
                            (addr+ addr code)))))))
   ((pair? x)
    (let ((kar (dump-object (car x) addr)))
      `(,@kar
        ,@(dump-object (cdr x) (addr+ addr kar))
        (cons))))
   ((vector? x)
    (let* ((len (vector-length x))
           (tail (if (>= len 65536)
                     (too-long "vector")
                     `((vector ,(quotient len 256) ,(modulo len 256))))))
      (let dump-objects ((i 0) (codes '()) (addr addr))
        (if (>= i len)
            (fold append tail codes)
            (let ((code (dump-object (vector-ref x i) addr)))
              (dump-objects (1+ i) (cons code codes)
                            (addr+ addr code)))))))
   ((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))))
Commit	Line	Data
f1d7723b AW	1	;;; Guile VM assembler
f1d7723b AW	2
b912a1cd	3	;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
f1d7723b	4
53befeb7 NJ	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
f1d7723b AW	18
	19	;;; Code:
	20
	21	(define-module (language glil compile-assembly)
	22	#:use-module (system base syntax)
	23	#:use-module (system base pmatch)
	24	#:use-module (language glil)
	25	#:use-module (language assembly)
	26	#:use-module (system vm instruction)
	27	#:use-module ((system vm program) #:select (make-binding))
f1d7723b AW	28	#:use-module (ice-9 receive)
f1d7723b AW	29	#:use-module ((srfi srfi-1) #:select (fold))
782a82ee	30	#:use-module (rnrs bytevector)
f1d7723b AW	31	#:export (compile-assembly))
	32
	33	;; Variable cache cells go in the object table, and serialize as their
	34	;; keys. The reason we wrap the keys in these records is so they don't
	35	;; compare as `equal?' to other objects in the object table.
	36	;;
	37	;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
	38
	39	(define-record <variable-cache-cell> key)
	40
	41	;; Subprograms can be loaded into an object table as well. We need a
2cf1705c AW	42	;; disjoint type here too. (Subprograms have their own object tables --
2cf1705c AW	43	;; though probably we should just make one table per compilation unit.)
f1d7723b	44
2cf1705c	45	(define-record <subprogram> table prog)
f1d7723b AW	46
f1d7723b AW	47
028e3d06 AW	48	(define (limn-sources sources)
	49	(let lp ((in sources) (out '()) (filename #f))
	50	(if (null? in)
	51	(reverse! out)
	52	(let ((addr (caar in))
	53	(new-filename (assq-ref (cdar in ) 'filename))
	54	(line (assq-ref (cdar in) 'line))
	55	(column (assq-ref (cdar in) 'column)))
	56	(cond
	57	((not (equal? new-filename filename))
	58	(lp (cdr in)
	59	`((,addr . (,line . ,column))
ff33605d	60	(filename . ,new-filename)
028e3d06 AW	61	. ,out)
	62	new-filename))
	63	((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
	64	(lp (cdr in)
	65	`((,addr . (,line . ,column))
	66	. ,out)
	67	filename))
	68	(else
	69	(lp (cdr in) out filename)))))))
	70
f1d7723b AW	71	(define (make-meta bindings sources tail)
	72	(if (and (null? bindings) (null? sources) (null? tail))
	73	#f
ac47d5f6 AW	74	(compile-assembly
	75	(make-glil-program 0 0 0 0 '()
	76	(list
	77	(make-glil-const `(,bindings ,sources ,@tail))
131f7d6c	78	(make-glil-call 'return 1))))))
f1d7723b AW	79
f1d7723b AW	80	;; A functional stack of names of live variables.
66d3e9a3 AW	81	(define (make-open-binding name boxed? index)
66d3e9a3 AW	82	(list name boxed? index))
f1d7723b AW	83	(define (make-closed-binding open-binding start end)
	84	(make-binding (car open-binding) (cadr open-binding)
	85	(caddr open-binding) start end))
cf10678f	86	(define (open-binding bindings vars start)
f1d7723b AW	87	(cons
	88	(acons start
	89	(map
	90	(lambda (v)
	91	(pmatch v
66d3e9a3 AW	92	((,name ,boxed? ,i)
66d3e9a3 AW	93	(make-open-binding name boxed? i))
cf10678f	94	(else (error "unknown binding type" v))))
f1d7723b AW	95	vars)
	96	(car bindings))
	97	(cdr bindings)))
	98	(define (close-binding bindings end)
	99	(pmatch bindings
	100	((((,start . ,closing) . ,open) . ,closed)
	101	(cons open
	102	(fold (lambda (o tail)
	103	;; the cons is for dsu sort
	104	(acons start (make-closed-binding o start end)
	105	tail))
	106	closed
	107	closing)))
	108	(else (error "broken bindings" bindings))))
	109	(define (close-all-bindings bindings end)
	110	(if (null? (car bindings))
	111	(map cdr
	112	(stable-sort (reverse (cdr bindings))
	113	(lambda (x y) (< (car x) (car y)))))
	114	(close-all-bindings (close-binding bindings end) end)))
	115
	116	;; A functional object table.
ac47d5f6	117	(define module 1)
53e28ed9 AW	118	(define (assoc-ref-or-acons alist x make-y)
53e28ed9 AW	119	(cond ((assoc-ref alist x)
f1d7723b AW	120	=> (lambda (y) (values y alist)))
	121	(else
	122	(let ((y (make-y x alist)))
53e28ed9	123	(values y (acons x y alist))))))
f1d7723b	124	(define (object-index-and-alist x alist)
53e28ed9	125	(assoc-ref-or-acons alist x
f1d7723b	126	(lambda (x alist)
ac47d5f6	127	(+ (length alist) module))))
f1d7723b AW	128
	129	(define (compile-assembly glil)
	130	(receive (code . _)
cf10678f	131	(glil->assembly glil '() '(()) '() '() #f -1)
f1d7723b	132	(car code)))
ac47d5f6 AW	133	(define (make-object-table objects)
	134	(and (not (null? objects))
	135	(list->vector (cons #f objects))))
f1d7723b	136
cf10678f	137	(define (glil->assembly glil nexts-stack bindings
f1d7723b AW	138	source-alist label-alist object-alist addr)
f1d7723b AW	139	(define (emit-code x)
194566b0	140	(values (map assembly-pack x) bindings source-alist label-alist object-alist))
f1d7723b	141	(define (emit-code/object x object-alist)
194566b0	142	(values (map assembly-pack x) bindings source-alist label-alist object-alist))
f1d7723b AW	143
f1d7723b AW	144	(record-case glil
53e28ed9 AW	145	((<glil-program> nargs nrest nlocs nexts meta body closure-level)
	146	(let ((toplevel? (null? nexts-stack)))
	147	(define (process-body)
	148	(let ((nexts-stack (cons nexts nexts-stack)))
	149	(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
	150	(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
	151	(cond
	152	((null? body)
	153	(values (reverse code)
	154	(close-all-bindings bindings addr)
028e3d06	155	(limn-sources (reverse! source-alist))
53e28ed9 AW	156	(reverse label-alist)
	157	(and object-alist (map car (reverse object-alist)))
	158	addr))
	159	(else
	160	(receive (subcode bindings source-alist label-alist object-alist)
cf10678f	161	(glil->assembly (car body) nexts-stack bindings
53e28ed9 AW	162	source-alist label-alist object-alist addr)
	163	(lp (cdr body) (append (reverse subcode) code)
	164	bindings source-alist label-alist object-alist
2cf1705c	165	(addr+ addr subcode))))))))
53e28ed9 AW	166
	167	(receive (code bindings sources labels objects len)
	168	(process-body)
	169	(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
ac47d5f6 AW	170	,len
	171	,(make-meta bindings sources meta)
	172	. ,code)))
f1d7723b	173	(cond
53e28ed9 AW	174	(toplevel?
	175	;; toplevel bytecode isn't loaded by the vm, no way to do
	176	;; object table or closure capture (not in the bytecode,
	177	;; anyway)
1005628a	178	(emit-code (align-program prog addr)))
f1d7723b	179	(else
ac47d5f6	180	(let ((table (dump-object (make-object-table objects) addr))
53e28ed9 AW	181	(closure (if (> closure-level 0) '((make-closure)) '())))
	182	(cond
	183	(object-alist
	184	;; if we are being compiled from something with an object
	185	;; table, cache the program there
	186	(receive (i object-alist)
2cf1705c	187	(object-index-and-alist (make-subprogram table prog)
53e28ed9	188	object-alist)
a9b0f876 AW	189	(emit-code/object `(,(if (< i 256)
	190	`(object-ref ,i)
	191	`(long-object-ref ,(quotient i 256)
	192	,(modulo i 256)))
	193	,@closure)
53e28ed9 AW	194	object-alist)))
	195	(else
	196	;; otherwise emit a load directly
1005628a AW	197	(emit-code `(,@table ,@(align-program prog (addr+ addr table))
1005628a AW	198	,@closure)))))))))))
f1d7723b AW	199
	200	((<glil-bind> vars)
	201	(values '()
cf10678f	202	(open-binding bindings vars addr)
f1d7723b AW	203	source-alist
	204	label-alist
	205	object-alist))
	206
	207	((<glil-mv-bind> vars rest)
	208	(values `((truncate-values ,(length vars) ,(if rest 1 0)))
cf10678f	209	(open-binding bindings vars addr)
f1d7723b AW	210	source-alist
	211	label-alist
	212	object-alist))
	213
	214	((<glil-unbind>)
	215	(values '()
	216	(close-binding bindings addr)
	217	source-alist
	218	label-alist
	219	object-alist))
	220
028e3d06	221	((<glil-source> props)
f1d7723b AW	222	(values '()
f1d7723b AW	223	bindings
028e3d06	224	(acons addr props source-alist)
f1d7723b AW	225	label-alist
	226	object-alist))
	227
	228	((<glil-void>)
	229	(emit-code '((void))))
	230
	231	((<glil-const> obj)
	232	(cond
4b318482	233	((object->assembly obj)
f1d7723b AW	234	=> (lambda (code)
	235	(emit-code (list code))))
	236	((not object-alist)
	237	(emit-code (dump-object obj addr)))
	238	(else
	239	(receive (i object-alist)
	240	(object-index-and-alist obj object-alist)
a9b0f876 AW	241	(emit-code/object (if (< i 256)
	242	`((object-ref ,i))
	243	`((long-object-ref ,(quotient i 256)
	244	,(modulo i 256))))
f1d7723b AW	245	object-alist)))))
f1d7723b AW	246
cf10678f	247	((<glil-local> op index)
f1d7723b AW	248	(emit-code (if (eq? op 'ref)
	249	`((local-ref ,index))
	250	`((local-set ,index)))))
	251
f1d7723b AW	252	((<glil-external> op depth index)
	253	(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
	254	(if (> d 0)
	255	(lp (1- d) (+ n (car stack)) (cdr stack))
	256	(if (eq? op 'ref)
	257	`((external-ref ,(+ n index)))
	258	`((external-set ,(+ n index))))))))
	259
66d3e9a3 AW	260	((<glil-lexical> local? boxed? op index)
	261	(emit-code
	262	`((,(if local?
	263	(case op
	264	((ref) (if boxed? 'local-boxed-ref 'local-ref))
	265	((set) (if boxed? 'local-boxed-set 'local-set))
	266	((box) 'box)
	267	((empty-box) 'empty-box)
	268	(else (error "what" op)))
	269	(case op
	270	((ref) (if boxed? 'closure-boxed-ref 'closure-ref))
	271	((set) (if boxed? 'closure-boxed-set (error "what." glil)))
	272	(else (error "what" op))))
	273	,index))))
	274
f1d7723b AW	275	((<glil-toplevel> op name)
	276	(case op
	277	((ref set)
	278	(cond
	279	((not object-alist)
	280	(emit-code `(,@(dump-object name addr)
	281	(link-now)
	282	,(case op
	283	((ref) '(variable-ref))
	284	((set) '(variable-set))))))
	285	(else
	286	(receive (i object-alist)
	287	(object-index-and-alist (make-variable-cache-cell name)
	288	object-alist)
a9b0f876 AW	289	(emit-code/object (if (< i 256)
	290	`((,(case op
	291	((ref) 'toplevel-ref)
	292	((set) 'toplevel-set))
	293	,i))
	294	`((,(case op
	295	((ref) 'long-toplevel-ref)
	296	((set) 'long-toplevel-set))
	297	,(quotient i 256)
	298	,(modulo i 256))))
f1d7723b AW	299	object-alist)))))
	300	((define)
	301	(emit-code `((define ,(symbol->string name))
	302	(variable-set))))
	303	(else
	304	(error "unknown toplevel var kind" op name))))
	305
	306	((<glil-module> op mod name public?)
	307	(let ((key (list mod name public?)))
	308	(case op
	309	((ref set)
	310	(cond
	311	((not object-alist)
	312	(emit-code `(,@(dump-object key addr)
	313	(link-now)
	314	,(case op
	315	((ref) '(variable-ref))
	316	((set) '(variable-set))))))
	317	(else
	318	(receive (i object-alist)
53e28ed9	319	(object-index-and-alist (make-variable-cache-cell key)
f1d7723b AW	320	object-alist)
	321	(emit-code/object (case op
	322	((ref) `((toplevel-ref ,i)))
	323	((set) `((toplevel-set ,i))))
	324	object-alist)))))
	325	(else
	326	(error "unknown module var kind" op key)))))
	327
	328	((<glil-label> label)
	329	(values '()
	330	bindings
	331	source-alist
	332	(acons label addr label-alist)
	333	object-alist))
	334
	335	((<glil-branch> inst label)
	336	(emit-code `((,inst ,label))))
	337
	338	;; nargs is number of stack args to insn. probably should rename.
	339	((<glil-call> inst nargs)
	340	(if (not (instruction? inst))
	341	(error "Unknown instruction:" inst))
	342	(let ((pops (instruction-pops inst)))
	343	(cond ((< pops 0)
c11f46af AW	344	(case (instruction-length inst)
	345	((1) (emit-code `((,inst ,nargs))))
	346	((2) (emit-code `((,inst ,(quotient nargs 256)
	347	,(modulo nargs 256)))))
	348	(else (error "Unknown length for variable-arg instruction:"
	349	inst (instruction-length inst)))))
f1d7723b AW	350	((= pops nargs)
	351	(emit-code `((,inst))))
	352	(else
	353	(error "Wrong number of stack arguments to instruction:" inst nargs)))))
	354
	355	((<glil-mv-call> nargs ra)
	356	(emit-code `((mv-call ,nargs ,ra))))))
	357
f1d7723b AW	358	(define (dump-object x addr)
	359	(define (too-long x)
	360	(error (string-append x " too long")))
	361
2cf1705c AW	362	(cond
	363	((object->assembly x) => list)
	364	((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
	365	((subprogram? x)
	366	`(,@(subprogram-table x)
	367	,@(align-program (subprogram-prog x)
	368	(addr+ addr (subprogram-table x)))))
2cf1705c AW	369	((number? x)
	370	`((load-number ,(number->string x))))
	371	((string? x)
	372	`((load-string ,x)))
	373	((symbol? x)
	374	`((load-symbol ,(symbol->string x))))
	375	((keyword? x)
	376	`((load-keyword ,(symbol->string (keyword->symbol x)))))
	377	((list? x)
	378	(let ((tail (let ((len (length x)))
	379	(if (>= len 65536) (too-long "list"))
	380	`((list ,(quotient len 256) ,(modulo len 256))))))
	381	(let dump-objects ((objects x) (codes '()) (addr addr))
	382	(if (null? objects)
	383	(fold append tail codes)
	384	(let ((code (dump-object (car objects) addr)))
	385	(dump-objects (cdr objects) (cons code codes)
	386	(addr+ addr code)))))))
	387	((pair? x)
	388	(let ((kar (dump-object (car x) addr)))
	389	`(,@kar
	390	,@(dump-object (cdr x) (addr+ addr kar))
	391	(cons))))
	392	((vector? x)
	393	(let* ((len (vector-length x))
	394	(tail (if (>= len 65536)
	395	(too-long "vector")
	396	`((vector ,(quotient len 256) ,(modulo len 256))))))
	397	(let dump-objects ((i 0) (codes '()) (addr addr))
	398	(if (>= i len)
	399	(fold append tail codes)
	400	(let ((code (dump-object (vector-ref x i) addr)))
	401	(dump-objects (1+ i) (cons code codes)
	402	(addr+ addr code)))))))
782a82ee AW	403	((and (array? x) (symbol? (array-type x)))
	404	(let* ((type (dump-object (array-type x) addr))
	405	(shape (dump-object (array-shape x) (addr+ addr type))))
	406	`(,@type
	407	,@shape
	408	,@(align-code
	409	`(load-array ,(uniform-array->bytevector x))
	410	(addr+ (addr+ addr type) shape)
	411	8
	412	4))))
2cf1705c AW	413	(else
2cf1705c AW	414	(error "assemble: unrecognized object" x))))
f1d7723b	415