[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)
  :use-module (system vm conv)
  :use-module (ice-9 match)
  :use-module (ice-9 regex)
  :use-module (ice-9 common-list)
  :export (assemble))

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

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

(define-structure (<vm-asm> venv glil body))
(define-structure (venv parent nexts closure?))
(define-structure (vmod id))
(define-structure (vlink module name))
(define-structure (bytespec nargs nrest nlocs nexts bytes objs))

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

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

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

(define (codegen glil toplevel)
  (match glil
    (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
     (let ((stack '())
	   (label-alist '())
	   (object-alist '()))
       (define (push-code! code)
	 (set! stack (optimizing-push code stack)))
       (define (push-object! x)
	 (cond ((object->code x) => push-code!)
	       (toplevel
		;; top-level object-dump
		(cond ((object-assoc x object-alist) =>
		       (lambda (obj+index)
			 (cond ((not (cdr obj+index))
				(set-cdr! obj+index nlocs)
				(set! nlocs (+ nlocs 1))))
			 (push-code! `(local-ref ,(cdr obj+index)))))
		      (else
		       (set! object-alist (acons x #f object-alist))
		       (push-code! `(object-dump ,x)))))
	       (else
		;; local object-ref
		(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 (label-ref key)
	 (assq-ref label-alist key))
       (define (label-set key)
	 (let ((addr (apply + (map length stack))))
	   (set! label-alist (assq-set! label-alist key addr))))
       (define (generate-code x)
	 (match x
	   (($ <vm-asm> venv)
	    (push-object! (codegen x #f))
	    (if (venv-closure? venv) (push-code! `(make-closure))))

	   (($ <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 ,(+ nargs index)))
		(push-code! `(local-set ,(+ nargs index)))))

	   (($ <glil-external> op depth index)
	    (do ((e venv (venv-parent e))
		 (d depth (1- d))
		 (n 0 (+ n (venv-nexts e))))
		((= 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! (make-vlink #f name))	;; FIXME: (make-vmod module)
	    (if (eq? op 'ref)
		(push-code! '(variable-ref))
		(push-code! '(variable-set))))

	   (($ <glil-label> label)
	    (label-set label))

	   (($ <glil-branch> inst label)
	    (let ((setter (lambda (addr) (- (label-ref label) addr))))
	      (push-code! (list inst setter))))

	   (($ <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)
       (if toplevel
	   ;; top-level
	   (let ((new '()))
	     (define (push-code! x)
	       (set! new (cons x new)))
	     (do ((stack (reverse! stack) (cdr stack)))
		 ((null? stack)
		  (make-dumpcode nlocs nexts (stack->bytes (reverse! new))))
	       (if (eq? (caar stack) 'object-dump)
		   (let ((x (cadar stack)))
		     (dump-object! push-code! x)
		     (cond ((object-assoc x object-alist) =>
			    (lambda (obj+index)
			      (cond ((cdr obj+index) =>
				     (lambda (n)
				       (push-code! '(dup))
				       (push-code! `(local-set ,n)))))))))
		   (push-code! (car stack)))))
	   ;; closures
	   (let ((bytes (stack->bytes (reverse! stack)))
		 (objs (map car (reverse! object-alist))))
	     (make-bytespec nargs nrest nlocs nexts bytes objs)))))))

(define (object-assoc x alist)
  (if (vlink? x) (assoc x alist) (assq x alist)))

(define (stack->bytes stack)
  (let loop ((result '()) (stack stack) (addr 0))
    (if (null? stack)
	(apply string-append (reverse! result))
	(let* ((orig (car stack))
	       (addr (+ addr (length orig)))
	       (code (if (and (pair? (cdr orig)) (procedure? (cadr orig)))
			 `(,(car orig) ,((cadr orig) addr))
			 orig)))
	  (loop (cons (code->bytes code) result) (cdr stack) addr)))))

\f
;;;
;;; Bytecode optimization
;;;

(define *optimization-table*
  '((not       (not       . not-not)
	       (eq?       . not-eq?)
	       (null?     . not-null?)
	       (not-not   . not)
	       (not-eq?   . eq?)
	       (not-null? . null?))
    (br-if     (not       . br-if-not)
	       (eq?       . br-if-eq)
	       (null?     . br-if-null)
	       (not-not   . br-if)
	       (not-eq?   . br-if-not-eq)
	       (not-null? . br-if-not-null))
    (br-if-not (not       . br-if)
	       (eq?       . br-if-not-eq)
	       (null?     . br-if-not-null)
	       (not-not   . br-if-not)
	       (not-eq?   . br-if-eq)
	       (not-null? . br-if-null))))

(define (optimizing-push code stack)
  (let ((alist (assq-ref *optimization-table* (car code))))
    (cond ((and alist (pair? stack) (assq-ref alist (caar stack))) =>
	   (lambda (inst) (cons (cons inst (cdr code)) (cdr stack))))
	  (else (cons (code-pack code) stack)))))

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

;; NOTE: undumpped in vm_load.c.

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