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

;;; Guile VM assembler

;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; This program 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 General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, 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))
  #: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 ext? index)
  (list name ext? 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 nargs start)
  (cons
   (acons start
          (map
           (lambda (v)
             (pmatch v
               ((,name argument ,i) (make-open-binding name #f i))
               ((,name local ,i) (make-open-binding name #f (+ nargs i)))
               ((,name external ,i) (make-open-binding name #t i))
               (else (error "unknown binding type" name type))))
           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 0 '() '(()) '() '() #f -1)
    (car code)))
(define (make-object-table objects)
  (and (not (null? objects))
       (list->vector (cons #f objects))))

(define (glil->assembly glil nargs 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) nargs 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 `((object-ref ,i) ,@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 nargs 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 nargs 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 `((object-ref ,i))
                           object-alist)))))

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

    ((<glil-local> op index)
     (emit-code (if (eq? op 'ref)
                    `((local-ref ,(+ nargs index)))
                    `((local-set ,(+ nargs 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-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 (case op
                                ((ref) `((toplevel-ref ,i)))
                                ((set) `((toplevel-set ,i))))
                              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)
              (emit-code `((,inst ,nargs))))
             ((= 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)))))
   ((and (integer? x) (exact? x))
    (let ((str (do ((n x (quotient n 256))
                    (l '() (cons (modulo n 256) l)))
                   ((= n 0)
                    (list->string (map integer->char l))))))
      (if (< x 0)
	  `((load-integer ,str))
	  `((load-unsigned-integer ,str)))))
   ((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)))))))
   (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 AW	4
	5	;; This program is free software; you can redistribute it and/or modify
	6	;; it under the terms of the GNU General Public License as published by
	7	;; the Free Software Foundation; either version 2, or (at your option)
	8	;; any later version.
	9	;;
	10	;; This program 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
	13	;; GNU General Public License for more details.
	14	;;
	15	;; You should have received a copy of the GNU General Public License
	16	;; along with this program; see the file COPYING. If not, write to
	17	;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	18	;; Boston, MA 02111-1307, USA.
	19
	20	;;; Code:
	21
	22	(define-module (language glil compile-assembly)
	23	#:use-module (system base syntax)
	24	#:use-module (system base pmatch)
	25	#:use-module (language glil)
	26	#:use-module (language assembly)
	27	#:use-module (system vm instruction)
	28	#:use-module ((system vm program) #:select (make-binding))
f1d7723b AW	29	#:use-module (ice-9 receive)
	30	#:use-module ((srfi srfi-1) #:select (fold))
	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))
	60	(filename ,new-filename)
	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
	80	;; A functional stack of names of live variables.
	81	(define (make-open-binding name ext? index)
	82	(list name ext? index))
	83	(define (make-closed-binding open-binding start end)
	84	(make-binding (car open-binding) (cadr open-binding)
	85	(caddr open-binding) start end))
	86	(define (open-binding bindings vars nargs start)
	87	(cons
	88	(acons start
	89	(map
	90	(lambda (v)
	91	(pmatch v
	92	((,name argument ,i) (make-open-binding name #f i))
	93	((,name local ,i) (make-open-binding name #f (+ nargs i)))
	94	((,name external ,i) (make-open-binding name #t i))
	95	(else (error "unknown binding type" name type))))
	96	vars)
	97	(car bindings))
	98	(cdr bindings)))
	99	(define (close-binding bindings end)
	100	(pmatch bindings
	101	((((,start . ,closing) . ,open) . ,closed)
	102	(cons open
	103	(fold (lambda (o tail)
	104	;; the cons is for dsu sort
	105	(acons start (make-closed-binding o start end)
	106	tail))
	107	closed
	108	closing)))
	109	(else (error "broken bindings" bindings))))
	110	(define (close-all-bindings bindings end)
	111	(if (null? (car bindings))
	112	(map cdr
	113	(stable-sort (reverse (cdr bindings))
	114	(lambda (x y) (< (car x) (car y)))))
	115	(close-all-bindings (close-binding bindings end) end)))
	116
	117	;; A functional object table.
ac47d5f6	118	(define module 1)
53e28ed9 AW	119	(define (assoc-ref-or-acons alist x make-y)
53e28ed9 AW	120	(cond ((assoc-ref alist x)
f1d7723b AW	121	=> (lambda (y) (values y alist)))
	122	(else
	123	(let ((y (make-y x alist)))
53e28ed9	124	(values y (acons x y alist))))))
f1d7723b	125	(define (object-index-and-alist x alist)
53e28ed9	126	(assoc-ref-or-acons alist x
f1d7723b	127	(lambda (x alist)
ac47d5f6	128	(+ (length alist) module))))
f1d7723b AW	129
	130	(define (compile-assembly glil)
	131	(receive (code . _)
1005628a	132	(glil->assembly glil 0 '() '(()) '() '() #f -1)
f1d7723b	133	(car code)))
ac47d5f6 AW	134	(define (make-object-table objects)
	135	(and (not (null? objects))
	136	(list->vector (cons #f objects))))
f1d7723b AW	137
	138	(define (glil->assembly glil nargs nexts-stack bindings
	139	source-alist label-alist object-alist addr)
	140	(define (emit-code x)
194566b0	141	(values (map assembly-pack x) bindings source-alist label-alist object-alist))
f1d7723b	142	(define (emit-code/object x object-alist)
194566b0	143	(values (map assembly-pack x) bindings source-alist label-alist object-alist))
f1d7723b AW	144
f1d7723b AW	145	(record-case glil
53e28ed9 AW	146	((<glil-program> nargs nrest nlocs nexts meta body closure-level)
	147	(let ((toplevel? (null? nexts-stack)))
	148	(define (process-body)
	149	(let ((nexts-stack (cons nexts nexts-stack)))
	150	(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
	151	(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
	152	(cond
	153	((null? body)
	154	(values (reverse code)
	155	(close-all-bindings bindings addr)
028e3d06	156	(limn-sources (reverse! source-alist))
53e28ed9 AW	157	(reverse label-alist)
	158	(and object-alist (map car (reverse object-alist)))
	159	addr))
	160	(else
	161	(receive (subcode bindings source-alist label-alist object-alist)
	162	(glil->assembly (car body) nargs nexts-stack bindings
	163	source-alist label-alist object-alist addr)
	164	(lp (cdr body) (append (reverse subcode) code)
	165	bindings source-alist label-alist object-alist
2cf1705c	166	(addr+ addr subcode))))))))
53e28ed9 AW	167
	168	(receive (code bindings sources labels objects len)
	169	(process-body)
	170	(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
ac47d5f6 AW	171	,len
	172	,(make-meta bindings sources meta)
	173	. ,code)))
f1d7723b	174	(cond
53e28ed9 AW	175	(toplevel?
	176	;; toplevel bytecode isn't loaded by the vm, no way to do
	177	;; object table or closure capture (not in the bytecode,
	178	;; anyway)
1005628a	179	(emit-code (align-program prog addr)))
f1d7723b	180	(else
ac47d5f6	181	(let ((table (dump-object (make-object-table objects) addr))
53e28ed9 AW	182	(closure (if (> closure-level 0) '((make-closure)) '())))
	183	(cond
	184	(object-alist
	185	;; if we are being compiled from something with an object
	186	;; table, cache the program there
	187	(receive (i object-alist)
2cf1705c	188	(object-index-and-alist (make-subprogram table prog)
53e28ed9 AW	189	object-alist)
	190	(emit-code/object `((object-ref ,i) ,@closure)
	191	object-alist)))
	192	(else
	193	;; otherwise emit a load directly
1005628a AW	194	(emit-code `(,@table ,@(align-program prog (addr+ addr table))
1005628a AW	195	,@closure)))))))))))
f1d7723b AW	196
	197	((<glil-bind> vars)
	198	(values '()
	199	(open-binding bindings vars nargs addr)
	200	source-alist
	201	label-alist
	202	object-alist))
	203
	204	((<glil-mv-bind> vars rest)
	205	(values `((truncate-values ,(length vars) ,(if rest 1 0)))
	206	(open-binding bindings vars nargs addr)
	207	source-alist
	208	label-alist
	209	object-alist))
	210
	211	((<glil-unbind>)
	212	(values '()
	213	(close-binding bindings addr)
	214	source-alist
	215	label-alist
	216	object-alist))
	217
028e3d06	218	((<glil-source> props)
f1d7723b AW	219	(values '()
f1d7723b AW	220	bindings
028e3d06	221	(acons addr props source-alist)
f1d7723b AW	222	label-alist
	223	object-alist))
	224
	225	((<glil-void>)
	226	(emit-code '((void))))
	227
	228	((<glil-const> obj)
	229	(cond
4b318482	230	((object->assembly obj)
f1d7723b AW	231	=> (lambda (code)
	232	(emit-code (list code))))
	233	((not object-alist)
	234	(emit-code (dump-object obj addr)))
	235	(else
	236	(receive (i object-alist)
	237	(object-index-and-alist obj object-alist)
	238	(emit-code/object `((object-ref ,i))
	239	object-alist)))))
	240
	241	((<glil-argument> op index)
	242	(emit-code (if (eq? op 'ref)
	243	`((local-ref ,index))
	244	`((local-set ,index)))))
	245
	246	((<glil-local> op index)
	247	(emit-code (if (eq? op 'ref)
	248	`((local-ref ,(+ nargs index)))
	249	`((local-set ,(+ nargs index))))))
	250
	251	((<glil-external> op depth index)
	252	(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
	253	(if (> d 0)
	254	(lp (1- d) (+ n (car stack)) (cdr stack))
	255	(if (eq? op 'ref)
	256	`((external-ref ,(+ n index)))
	257	`((external-set ,(+ n index))))))))
	258
	259	((<glil-toplevel> op name)
	260	(case op
	261	((ref set)
	262	(cond
	263	((not object-alist)
	264	(emit-code `(,@(dump-object name addr)
	265	(link-now)
	266	,(case op
	267	((ref) '(variable-ref))
	268	((set) '(variable-set))))))
	269	(else
	270	(receive (i object-alist)
	271	(object-index-and-alist (make-variable-cache-cell name)
	272	object-alist)
	273	(emit-code/object (case op
	274	((ref) `((toplevel-ref ,i)))
	275	((set) `((toplevel-set ,i))))
	276	object-alist)))))
	277	((define)
	278	(emit-code `((define ,(symbol->string name))
	279	(variable-set))))
	280	(else
	281	(error "unknown toplevel var kind" op name))))
	282
	283	((<glil-module> op mod name public?)
	284	(let ((key (list mod name public?)))
	285	(case op
	286	((ref set)
	287	(cond
	288	((not object-alist)
	289	(emit-code `(,@(dump-object key addr)
	290	(link-now)
	291	,(case op
	292	((ref) '(variable-ref))
	293	((set) '(variable-set))))))
	294	(else
295	(receive (i object-alist)
53e28ed9	296	(object-index-and-alist (make-variable-cache-cell key)
f1d7723b AW	297	object-alist)
	298	(emit-code/object (case op
	299	((ref) `((toplevel-ref ,i)))
	300	((set) `((toplevel-set ,i))))
	301	object-alist)))))
	302	(else
	303	(error "unknown module var kind" op key)))))
	304
	305	((<glil-label> label)
	306	(values '()
	307	bindings
	308	source-alist
	309	(acons label addr label-alist)
	310	object-alist))
	311
	312	((<glil-branch> inst label)
	313	(emit-code `((,inst ,label))))
	314
	315	;; nargs is number of stack args to insn. probably should rename.
	316	((<glil-call> inst nargs)
	317	(if (not (instruction? inst))
	318	(error "Unknown instruction:" inst))
	319	(let ((pops (instruction-pops inst)))
	320	(cond ((< pops 0)
	321	(emit-code `((,inst ,nargs))))
	322	((= pops nargs)
	323	(emit-code `((,inst))))
	324	(else
	325	(error "Wrong number of stack arguments to instruction:" inst nargs)))))
	326
	327	((<glil-mv-call> nargs ra)
	328	(emit-code `((mv-call ,nargs ,ra))))))
	329
f1d7723b AW	330	(define (dump-object x addr)
	331	(define (too-long x)
	332	(error (string-append x " too long")))
	333
2cf1705c AW	334	(cond
	335	((object->assembly x) => list)
	336	((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
	337	((subprogram? x)
	338	`(,@(subprogram-table x)
	339	,@(align-program (subprogram-prog x)
	340	(addr+ addr (subprogram-table x)))))
	341	((and (integer? x) (exact? x))
	342	(let ((str (do ((n x (quotient n 256))
	343	(l '() (cons (modulo n 256) l)))
	344	((= n 0)
	345	(list->string (map integer->char l))))))
b912a1cd LC	346	(if (< x 0)
	347	`((load-integer ,str))
	348	`((load-unsigned-integer ,str)))))
2cf1705c AW	349	((number? x)
	350	`((load-number ,(number->string x))))
	351	((string? x)
	352	`((load-string ,x)))
	353	((symbol? x)
	354	`((load-symbol ,(symbol->string x))))
	355	((keyword? x)
	356	`((load-keyword ,(symbol->string (keyword->symbol x)))))
	357	((list? x)
	358	(let ((tail (let ((len (length x)))
	359	(if (>= len 65536) (too-long "list"))
	360	`((list ,(quotient len 256) ,(modulo len 256))))))
	361	(let dump-objects ((objects x) (codes '()) (addr addr))
	362	(if (null? objects)
	363	(fold append tail codes)
	364	(let ((code (dump-object (car objects) addr)))
	365	(dump-objects (cdr objects) (cons code codes)
	366	(addr+ addr code)))))))
	367	((pair? x)
	368	(let ((kar (dump-object (car x) addr)))
	369	`(,@kar
	370	,@(dump-object (cdr x) (addr+ addr kar))
	371	(cons))))
	372	((vector? x)
	373	(let* ((len (vector-length x))
	374	(tail (if (>= len 65536)
	375	(too-long "vector")
	376	`((vector ,(quotient len 256) ,(modulo len 256))))))
	377	(let dump-objects ((i 0) (codes '()) (addr addr))
	378	(if (>= i len)
	379	(fold append tail codes)
	380	(let ((code (dump-object (vector-ref x i) addr)))
	381	(dump-objects (1+ i) (cons code codes)
	382	(addr+ addr code)))))))
	383	(else
	384	(error "assemble: unrecognized object" x))))
f1d7723b	385