[bpt/guile.git] / module / system / vm / assemble.scm

;;; Guile VM assembler

;; Copyright (C) 2001 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 (system vm assemble)
  :use-syntax (system base syntax)
  :use-module (system il glil)
  :use-module ((system vm core)
	       :select (instruction? instruction-pops
		        make-binding
			bytecode->objcode))
  :use-module (system vm conv)
  :use-module (ice-9 match)
  :use-module (ice-9 regex)
  :use-module (ice-9 common-list)
  :use-module (srfi srfi-4)
  :export (preprocess codegen assemble))

(define (assemble glil env . opts)
  (codegen (preprocess glil #f) #t))

\f
;;;
;;; Types
;;;

(define-record (<vm-asm> venv glil body))
(define-record (<venv> parent nexts closure?))
(define-record (<vmod> id))
(define-record (<vlink> module name))
(define-record (<bytespec> vars bytes meta objs closure?))

\f
;;;
;;; Stage 1: Preprocess
;;;

(define (preprocess x e)
  (match x
    (($ <glil-asm> vars body)
     (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
	    (body (map (lambda (x) (preprocess x venv)) body)))
       (<vm-asm> :venv venv :glil x :body body)))
    (($ <glil-external> op depth index)
     (do ((d depth (- d 1))
 	  (e e (slot e 'parent)))
 	 ((= d 0))
       (set! (slot e 'closure?) #t))
     x)
    (else x)))

\f
;;;
;;; Stage 2: Bytecode generation
;;;

(define (codegen glil toplevel)
  (match glil
    (($ <vm-asm> venv ($ <glil-asm> vars _) body)
     (let ((stack '())
	   (binding-alist '())
	   (source-alist '())
	   (label-alist '())
	   (object-alist '()))
       (define (push-code! code)
;	 (format #t "push-code! ~a~%" code)
	 (set! stack (cons (code->bytes code) stack)))
       (define (push-object! x)
	 (cond ((object->code x) => push-code!)
	       (toplevel (dump-object! push-code! x))
	       (else
		(let ((i (cond ((object-assoc x object-alist) => cdr)
			       (else
				(let ((i (length object-alist)))
				  (set! object-alist (acons x i object-alist))
				  i)))))
		  (push-code! `(object-ref ,i))))))
       (define (current-address)
	 (define (byte-length x)
	   (cond ((u8vector? x) (u8vector-length x))
		 (else 3)))
	 (apply + (map byte-length stack)))
       (define (generate-code x)
	 (match x
	   (($ <vm-asm> venv)
	    (push-object! (codegen x #f))
	    (if (slot venv 'closure?) (push-code! `(make-closure))))

	   (($ <glil-bind> binds)
	    (let ((bindings
		   (map (lambda (v)
			  (let ((name (car v)) (type (cadr v)) (i (caddr v)))
			    (case type
			      ((argument) (make-binding name #f i))
			      ((local) (make-binding name #f (+ vars.nargs i)))
			      ((external) (make-binding name #t i)))))
			binds)))
	      (set! binding-alist
		    (acons (current-address) bindings binding-alist))))

	   (($ <glil-unbind>)
	    (set! binding-alist (acons (current-address) #f binding-alist)))

	   (($ <glil-source> loc)
	    (set! source-alist (acons (current-address) loc source-alist)))

	   (($ <glil-void>)
	    (push-code! '(void)))

	   (($ <glil-const> x)
	    (push-object! x))

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

	   (($ <glil-local> op index)
	    (if (eq? op 'ref)
		(push-code! `(local-ref ,(+ vars.nargs index)))
		(push-code! `(local-set ,(+ vars.nargs index)))))

	   (($ <glil-external> op depth index)
	    (do ((e venv e.parent)
		 (d depth (1- d))
		 (n 0 (+ n e.nexts)))
		((= d 0)
		 (if (eq? op 'ref)
		     (push-code! `(external-ref ,(+ n index)))
		     (push-code! `(external-set ,(+ n index)))))))

	   (($ <glil-module> op module name)
	    (push-object! (<vlink> :module #f :name name))
	    (if (eq? op 'ref)
		(push-code! '(variable-ref))
		(push-code! '(variable-set))))

	   (($ <glil-label> label)
	    (set! label-alist (assq-set! label-alist label (current-address))))

	   (($ <glil-branch> inst label)
	    (set! stack (cons (list inst label) stack)))

	   (($ <glil-call> inst nargs)
	    (if (instruction? inst)
		(let ((pops (instruction-pops inst)))
		  (cond ((< pops 0)
			 (push-code! (list inst nargs)))
			((= pops nargs)
			 (push-code! (list inst)))
			(else
			 (error "Wrong number of arguments:" inst nargs))))
		(error "Unknown instruction:" inst)))))
       ;;
       ;; main
       (for-each generate-code body)
;       (format #t "codegen: stack = ~a~%" (reverse stack))
       (let ((bytes (stack->bytes (reverse! stack) label-alist)))
	 (if toplevel
	     (bytecode->objcode bytes vars.nlocs vars.nexts)
	     (<bytespec> :vars vars :bytes bytes
			 :meta (if (and (null? binding-alist)
					(null? source-alist))
				 #f
				 (cons (reverse! binding-alist)
				       (reverse! source-alist)))
			 :objs (let ((objs (map car (reverse! object-alist))))
				 (if (null? objs) #f (list->vector objs)))
			 :closure? venv.closure?)))))))

(define (object-assoc x alist)
  (match x
    (($ <vlink>) (assoc x alist))
    (else        (assq x alist))))

(define (stack->bytes stack label-alist)
  (let loop ((result '()) (stack stack) (addr 0))
    (if (null? stack)
	(apply u8vector
	       (apply append
		      (map u8vector->list (reverse! result))))
	(let ((bytes (car stack)))
	  (if (pair? bytes)
	      (let* ((offset (- (assq-ref label-alist (cadr bytes))
				(+ addr 3)))
		     (n (if (< offset 0) (+ offset 65536) offset)))
		(set! bytes (code->bytes (list (car bytes)
					       (quotient n 256)
					       (modulo n 256))))))
	  (loop (cons bytes result)
		(cdr stack)
		(+ addr (u8vector-length bytes)))))))

\f
;;;
;;; Object dump
;;;

;; NOTE: undumpped in vm_system.c

(define (dump-object! push-code! x)
  (define (too-long x)
    (error (string-append x " too long")))

  (let dump! ((x x))
    (cond
     ((object->code x) => push-code!)
     (else
      (match x
	(($ <bytespec> vars bytes meta objs closure?)
	 ;; dump parameters
	 (let ((nargs vars.nargs) (nrest vars.nrest)
	       (nlocs vars.nlocs) (nexts vars.nexts))
	   (cond
	     ((and (< nargs 4) (< nlocs 8) (< nexts 4))
	      ;; 8-bit representation
	      (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
		(push-code! `(make-int8 ,x))))
	     ((and (< nargs 16) (< nlocs 128) (< nexts 16))
	      ;; 16-bit representation
	      (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
		(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
	     (else
	      ;; Other cases
	      (push-code! (object->code nargs))
	      (push-code! (object->code nrest))
	      (push-code! (object->code nlocs))
	      (push-code! (object->code nexts))
	      (push-code! (object->code #f)))))
	 ;; dump object table
	 (if objs (dump! objs))
	 ;; dump meta data
	 (if meta (dump! meta))
	 ;; dump bytecode
	 (push-code! `(load-program ,bytes)))
	(($ <vlink> module name)
	 ;; FIXME: dump module
	 (push-code! `(link ,(symbol->string name))))
	(($ <vmod> id)
	 (push-code! `(load-module ,id)))
	((and ($ integer) ($ exact))
	 (let ((str (do ((n x (quotient n 256))
			 (l '() (cons (modulo n 256) l)))
			((= n 0)
			 (apply u8vector l)))))
	   (push-code! `(load-integer ,str))))
	(($ number)
	 (push-code! `(load-number ,(number->string x))))
	(($ string)
	 (push-code! `(load-string ,x)))
	(($ symbol)
	 (push-code! `(load-symbol ,(symbol->string x))))
	(($ keyword)
	 (push-code! `(load-keyword
		       ,(symbol->string (keyword-dash-symbol x)))))
	(($ list)
	 (for-each dump! x)
	 (let ((len (length x)))
	   (if (>= len 65536) (too-long 'list))
	   (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
	(($ pair)
	 (dump! (car x))
	 (dump! (cdr x))
	 (push-code! `(cons)))
	(($ vector)
	 (for-each dump! (vector->list x))
	 (let ((len (vector-length x)))
	   (if (>= len 65536) (too-long 'vector))
	   (push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
	(else
	 (error "assemble: unrecognized object" x)))))))
Commit	Line	Data
17e90c5e KN	1	;;; Guile VM assembler
	2
	3	;; Copyright (C) 2001 Free Software Foundation, Inc.
	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 (system vm assemble)
ac99cb0c	23	:use-syntax (system base syntax)
17e90c5e	24	:use-module (system il glil)
884d46de LC	25	:use-module ((system vm core)
	26	:select (instruction? instruction-pops
	27	make-binding
	28	bytecode->objcode))
17e90c5e KN	29	:use-module (system vm conv)
	30	:use-module (ice-9 match)
	31	:use-module (ice-9 regex)
	32	:use-module (ice-9 common-list)
054599f1	33	:use-module (srfi srfi-4)
0b5f0e49	34	:export (preprocess codegen assemble))
17e90c5e KN	35
17e90c5e KN	36	(define (assemble glil env . opts)
4bfb26f5	37	(codegen (preprocess glil #f) #t))
17e90c5e KN	38
	39	\f
	40	;;;
	41	;;; Types
	42	;;;
	43
ac99cb0c KN	44	(define-record (<vm-asm> venv glil body))
	45	(define-record (<venv> parent nexts closure?))
	46	(define-record (<vmod> id))
	47	(define-record (<vlink> module name))
	48	(define-record (<bytespec> vars bytes meta objs closure?))
17e90c5e KN	49
	50	\f
	51	;;;
	52	;;; Stage 1: Preprocess
	53	;;;
	54
	55	(define (preprocess x e)
	56	(match x
ac99cb0c	57	(($ <glil-asm> vars body)
0b5f0e49	58	(let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
17e90c5e	59	(body (map (lambda (x) (preprocess x venv)) body)))
ac99cb0c	60	(<vm-asm> :venv venv :glil x :body body)))
17e90c5e	61	(($ <glil-external> op depth index)
0b5f0e49	62	(do ((d depth (- d 1))
b6368dbb LC	63	(e e (slot e 'parent)))
b6368dbb LC	64	((= d 0))
0b5f0e49	65	(set! (slot e 'closure?) #t))
17e90c5e	66	x)
b6368dbb	67	(else x)))
17e90c5e KN	68
	69	\f
	70	;;;
	71	;;; Stage 2: Bytecode generation
	72	;;;
	73
	74	(define (codegen glil toplevel)
	75	(match glil
ac99cb0c	76	(($ <vm-asm> venv ($ <glil-asm> vars _) body)
17e90c5e	77	(let ((stack '())
af988bbf	78	(binding-alist '())
ac99cb0c	79	(source-alist '())
17e90c5e	80	(label-alist '())
3616e9e9	81	(object-alist '()))
17e90c5e	82	(define (push-code! code)
2d80426a	83	; (format #t "push-code! ~a~%" code)
41f248a8	84	(set! stack (cons (code->bytes code) stack)))
206a0622	85	(define (push-object! x)
880ed584	86	(cond ((object->code x) => push-code!)
41f248a8	87	(toplevel (dump-object! push-code! x))
f0c99935	88	(else
880ed584 KN	89	(let ((i (cond ((object-assoc x object-alist) => cdr)
	90	(else
	91	(let ((i (length object-alist)))
	92	(set! object-alist (acons x i object-alist))
	93	i)))))
	94	(push-code! `(object-ref ,i))))))
ac99cb0c KN	95	(define (current-address)
ac99cb0c KN	96	(define (byte-length x)
fa19602c	97	(cond ((u8vector? x) (u8vector-length x))
ac99cb0c KN	98	(else 3)))
ac99cb0c KN	99	(apply + (map byte-length stack)))
17e90c5e KN	100	(define (generate-code x)
17e90c5e KN	101	(match x
bd098a1a	102	(($ <vm-asm> venv)
f0c99935	103	(push-object! (codegen x #f))
0b5f0e49	104	(if (slot venv 'closure?) (push-code! `(make-closure))))
ac99cb0c KN	105
ac99cb0c KN	106	(($ <glil-bind> binds)
af988bbf KN	107	(let ((bindings
	108	(map (lambda (v)
	109	(let ((name (car v)) (type (cadr v)) (i (caddr v)))
	110	(case type
	111	((argument) (make-binding name #f i))
	112	((local) (make-binding name #f (+ vars.nargs i)))
	113	((external) (make-binding name #t i)))))
	114	binds)))
	115	(set! binding-alist
	116	(acons (current-address) bindings binding-alist))))
ac99cb0c KN	117
ac99cb0c KN	118	(($ <glil-unbind>)
af988bbf	119	(set! binding-alist (acons (current-address) #f binding-alist)))
ac99cb0c KN	120
	121	(($ <glil-source> loc)
	122	(set! source-alist (acons (current-address) loc source-alist)))
17e90c5e KN	123
17e90c5e KN	124	(($ <glil-void>)
41f248a8	125	(push-code! '(void)))
17e90c5e KN	126
17e90c5e KN	127	(($ <glil-const> x)
f0c99935	128	(push-object! x))
17e90c5e KN	129
17e90c5e KN	130	(($ <glil-argument> op index)
f0c99935	131	(if (eq? op 'ref)
532565b0 KN	132	(push-code! `(local-ref ,index))
532565b0 KN	133	(push-code! `(local-set ,index))))
17e90c5e KN	134
17e90c5e KN	135	(($ <glil-local> op index)
f0c99935	136	(if (eq? op 'ref)
ac99cb0c KN	137	(push-code! `(local-ref ,(+ vars.nargs index)))
ac99cb0c KN	138	(push-code! `(local-set ,(+ vars.nargs index)))))
17e90c5e KN	139
17e90c5e KN	140	(($ <glil-external> op depth index)
ac99cb0c	141	(do ((e venv e.parent)
17e90c5e	142	(d depth (1- d))
ac99cb0c	143	(n 0 (+ n e.nexts)))
17e90c5e	144	((= d 0)
f0c99935 KN	145	(if (eq? op 'ref)
	146	(push-code! `(external-ref ,(+ n index)))
	147	(push-code! `(external-set ,(+ n index)))))))
17e90c5e KN	148
17e90c5e KN	149	(($ <glil-module> op module name)
ac99cb0c	150	(push-object! (<vlink> :module #f :name name))
f0c99935 KN	151	(if (eq? op 'ref)
	152	(push-code! '(variable-ref))
	153	(push-code! '(variable-set))))
17e90c5e KN	154
17e90c5e KN	155	(($ <glil-label> label)
ac99cb0c	156	(set! label-alist (assq-set! label-alist label (current-address))))
17e90c5e KN	157
17e90c5e KN	158	(($ <glil-branch> inst label)
41f248a8	159	(set! stack (cons (list inst label) stack)))
17e90c5e	160
46cd9a34	161	(($ <glil-call> inst nargs)
17e90c5e	162	(if (instruction? inst)
46cd9a34 KN	163	(let ((pops (instruction-pops inst)))
	164	(cond ((< pops 0)
	165	(push-code! (list inst nargs)))
	166	((= pops nargs)
	167	(push-code! (list inst)))
	168	(else
	169	(error "Wrong number of arguments:" inst nargs))))
17e90c5e KN	170	(error "Unknown instruction:" inst)))))
	171	;;
	172	;; main
17e90c5e	173	(for-each generate-code body)
2d80426a	174	; (format #t "codegen: stack = ~a~%" (reverse stack))
41f248a8 KN	175	(let ((bytes (stack->bytes (reverse! stack) label-alist)))
41f248a8 KN	176	(if toplevel
ac99cb0c KN	177	(bytecode->objcode bytes vars.nlocs vars.nexts)
ac99cb0c KN	178	(<bytespec> :vars vars :bytes bytes
af988bbf	179	:meta (if (and (null? binding-alist)
ac99cb0c KN	180	(null? source-alist))
ac99cb0c KN	181	#f
af988bbf	182	(cons (reverse! binding-alist)
ac99cb0c KN	183	(reverse! source-alist)))
	184	:objs (let ((objs (map car (reverse! object-alist))))
	185	(if (null? objs) #f (list->vector objs)))
	186	:closure? venv.closure?)))))))
17e90c5e	187
880ed584	188	(define (object-assoc x alist)
ac99cb0c KN	189	(match x
	190	(($ <vlink>) (assoc x alist))
	191	(else (assq x alist))))
880ed584	192
41f248a8	193	(define (stack->bytes stack label-alist)
880ed584	194	(let loop ((result '()) (stack stack) (addr 0))
206a0622	195	(if (null? stack)
054599f1 LC	196	(apply u8vector
	197	(apply append
	198	(map u8vector->list (reverse! result))))
41f248a8 KN	199	(let ((bytes (car stack)))
	200	(if (pair? bytes)
	201	(let* ((offset (- (assq-ref label-alist (cadr bytes))
	202	(+ addr 3)))
	203	(n (if (< offset 0) (+ offset 65536) offset)))
	204	(set! bytes (code->bytes (list (car bytes)
	205	(quotient n 256)
	206	(modulo n 256))))))
	207	(loop (cons bytes result)
	208	(cdr stack)
054599f1	209	(+ addr (u8vector-length bytes)))))))
17e90c5e KN	210
	211	\f
	212	;;;
4bfb26f5	213	;;; Object dump
17e90c5e KN	214	;;;
17e90c5e KN	215
23b587b0	216	;; NOTE: undumpped in vm_system.c
17e90c5e	217
f0c99935	218	(define (dump-object! push-code! x)
23b587b0 LC	219	(define (too-long x)
	220	(error (string-append x " too long")))
	221
bd098a1a KN	222	(let dump! ((x x))
	223	(cond
	224	((object->code x) => push-code!)
ac99cb0c	225	(else
4bfb26f5	226	(match x
ac99cb0c	227	(($ <bytespec> vars bytes meta objs closure?)
4bfb26f5	228	;; dump parameters
ac99cb0c KN	229	(let ((nargs vars.nargs) (nrest vars.nrest)
	230	(nlocs vars.nlocs) (nexts vars.nexts))
	231	(cond
	232	((and (< nargs 4) (< nlocs 8) (< nexts 4))
	233	;; 8-bit representation
	234	(let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
	235	(push-code! `(make-int8 ,x))))
	236	((and (< nargs 16) (< nlocs 128) (< nexts 16))
	237	;; 16-bit representation
	238	(let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
	239	(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
	240	(else
	241	;; Other cases
	242	(push-code! (object->code nargs))
	243	(push-code! (object->code nrest))
	244	(push-code! (object->code nlocs))
	245	(push-code! (object->code nexts))
	246	(push-code! (object->code #f)))))
4bfb26f5	247	;; dump object table
ac99cb0c KN	248	(if objs (dump! objs))
	249	;; dump meta data
	250	(if meta (dump! meta))
4bfb26f5	251	;; dump bytecode
ac99cb0c KN	252	(push-code! `(load-program ,bytes)))
	253	(($ <vlink> module name)
	254	;; FIXME: dump module
fa19602c	255	(push-code! `(link ,(symbol->string name))))
ac99cb0c KN	256	(($ <vmod> id)
	257	(push-code! `(load-module ,id)))
	258	((and ($ integer) ($ exact))
	259	(let ((str (do ((n x (quotient n 256))
	260	(l '() (cons (modulo n 256) l)))
	261	((= n 0)
054599f1	262	(apply u8vector l)))))
ac99cb0c KN	263	(push-code! `(load-integer ,str))))
ac99cb0c KN	264	(($ number)
fa19602c	265	(push-code! `(load-number ,(number->string x))))
ac99cb0c	266	(($ string)
238e7a11	267	(push-code! `(load-string ,x)))
ac99cb0c	268	(($ symbol)
fa19602c	269	(push-code! `(load-symbol ,(symbol->string x))))
ac99cb0c KN	270	(($ keyword)
ac99cb0c KN	271	(push-code! `(load-keyword
fa19602c	272	,(symbol->string (keyword-dash-symbol x)))))
ac99cb0c KN	273	(($ list)
ac99cb0c KN	274	(for-each dump! x)
23b587b0 LC	275	(let ((len (length x)))
	276	(if (>= len 65536) (too-long 'list))
	277	(push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
ac99cb0c KN	278	(($ pair)
	279	(dump! (car x))
	280	(dump! (cdr x))
	281	(push-code! `(cons)))
	282	(($ vector)
	283	(for-each dump! (vector->list x))
23b587b0 LC	284	(let ((len (vector-length x)))
	285	(if (>= len 65536) (too-long 'vector))
	286	(push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
ac99cb0c	287	(else
884d46de	288	(error "assemble: unrecognized object" x)))))))