[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)
  (dump (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 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 '())
	   (nvars (+ nargs nlocs -1)))
       (define (current-address) (length stack))
       (define (push-code! code)
	 (set! stack (optimizing-push code stack)))
       (define (object-index obj)
	 (cond ((assq-ref object-alist obj))
	       (else (let ((index (length object-alist)))
		       (set! object-alist (acons obj index object-alist))
		       index))))
       (define (label-ref key)
	 (assq-ref label-alist key))
       (define (label-set key pos)
	 (set! label-alist (assq-set! label-alist key pos)))
       (define (generate-code x)
	 (match x
	   (($ <vm-asm> env)
	    (push-code! `(object-ref ,(object-index (codegen x #f))))
	    (if (venv-closure? env) (push-code! `(make-closure))))

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

	   (($ <glil-const> x)
	    (if toplevel
		(for-each push-code! (object->dump-code x))
		(cond ((object->code x) => push-code!)
		      (else (push-code! `(object-ref ,(object-index x)))))))

	   (($ <glil-argument> op index)
	    (push-code! (list (symbol-append 'local- op)
			      (- nvars index))))

	   (($ <glil-local> op index)
	    (push-code! (list (symbol-append 'local- op)
			      (- nvars (+ nargs index)))))

	   (($ <glil-external> op depth index)
	    (do ((e venv (venv-parent e))
		 (d depth (1- d))
		 (i 0 (+ i (venv-nexts e))))
		((= d 0)
		 (push-code! (list (symbol-append 'external- op)
				   (+ index i))))))

	   (($ <glil-module> op module name)
	    (if toplevel
		(begin
		  ;; (push-code! `(load-module ,module))
		  (push-code! `(load-symbol ,name))
		  (push-code! `(link/current-module)))
		;; (let ((vlink (make-vlink (make-vmod module) name)))
		(let ((vlink (make-vlink #f name)))
		  (push-code! `(object-ref ,(object-index vlink)))))
	    (push-code! (list (symbol-append 'variable- op))))

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

	   (($ <glil-branch> inst label)
	    (let ((setter (lambda (addr) (- (label-ref label) (1+ 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
       (if (> nexts 0) (push-code! `(external ,nexts)))
       (for-each generate-code body)
       (let ((bytes (code->bytes
		     (map/index (lambda (v n) (if (procedure? v) (v n) v))
				(reverse! stack))))
	     (objs (map car (reverse! object-alist))))
	 (make-bytespec nargs nrest nlocs bytes objs))))))

(define (map/index f l)
  (do ((n 0 (1+ n))
       (l l (cdr l))
       (r '() (cons (f (car l) n) r)))
      ((null? l) (reverse! r))))

;; Optimization

(define *optimize-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 *optimize-table* (car code))))
    (cond ((and alist (pair? stack) (assq-ref alist (car stack))) =>
	   (lambda (inst) (append! (reverse! (cons inst (cdr code)))
				   (cdr stack))))
	  (else (append! (reverse! (code-finalize code)) stack)))))

\f
;;;
;;; Stage3: Dumpcode generation
;;;

(define (dump bytespec)
  (let* ((table (build-object-table bytespec))
	 (bytes (bytespec->bytecode bytespec table '(return))))
    (if (null? table)
	bytes
	(let ((spec (make-bytespec 0 0 (length table) bytes '())))
	  (bytespec->bytecode spec '() '(tail-call 0))))))

(define (bytespec->bytecode bytespec object-table last-code)
  (let ((stack '()))
    (define (push-code! x)
      (set! stack (cons x stack)))
    (define (object-index x)
      (cond ((object-find object-table x) => cdr)
	    (else #f)))
    (define (dump-table-object! obj+index)
      (let dump! ((x (car obj+index)))
	(cond
	 ((vlink? x)
	  ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
	  (push-code! `(load-symbol ,(vlink-name x)))
	  (push-code! `(link/current-module)))
	 ((vmod? x)
	  (push-code! `(load-module ,(vmod-id x))))
	 (else
	  (for-each push-code! (object->dump-code x)))))
      (push-code! `(local-set ,(cdr obj+index))))
    (define (dump-object! x)
      (let dump! ((x x))
	(cond
	 ((bytespec? x) (dump-bytecode! x))
	 ((object-index x) => (lambda (i) (push-code! `(local-ref ,i))))
	 (else
	  (error "Cannot dump:" x)))))
    (define (dump-bytecode! spec)
      (let ((nargs (bytespec-nargs spec))
	    (nrest (bytespec-nrest spec))
	    (nlocs (bytespec-nlocs spec))
	    (objs  (bytespec-objs spec)))
	(if (and (null? objs) (< nargs 4) (< nlocs 16))
	    ;; zero-object encoding
	    (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
	    (begin
	      ;; dump parameters
	      (push-code! (object->code nargs))
	      (push-code! (object->code nrest))
	      (push-code! (object->code nlocs))
	      ;; dump object table
	      (cond ((null? objs) (push-code! (object->code #f)))
		    (else
		     (for-each dump-object! objs)
		     (push-code! `(vector ,(length objs)))))))
	;; dump bytecode
	(push-code! `(load-program ,(bytespec-bytes spec)))))
    ;;
    ;; main
    (for-each dump-table-object! object-table)
    (dump-bytecode! bytespec)
    (push-code! last-code)
    (code->bytes (apply append! (map code-finalize (reverse! stack))))))

;; object table

(define (object-find table x)
  ((if (or (vlink? x) (vmod? x)) assoc assq) x table))

(define (build-object-table bytespec)
  (let ((table '()) (index 0))
    (define (insert! x)
      ;; (if (vlink? x) (begin (insert! (vlink-module x))))
      (if (not (object-find table x))
	  (begin
	    (set! table (acons x index table))
	    (set! index (1+ index)))))
    (let loop ((spec bytespec))
      (for-each (lambda (x)
		  (if (bytespec? x) (loop x) (insert! x)))
		(bytespec-objs spec)))
    (reverse! table)))

;; code generation

(define (code-finalize code)
  (match code
    ((inst (? symbol? s))
     (let ((s (symbol->string s)))
       `(,inst ,(string-length s) ,s)))
    ((inst (? string? s))
     `(,inst ,(string-length s) ,s))
    (else (code-pack code))))

(define (integer->string n) (make-string 1 (integer->char n)))

(define (length->string len)
  (define C integer->char)
  (list->string
   (cond ((< len 254) (list (C len)))
	 ((< len 65536)
	  (list (C 254) (C (quotient len 256)) (C (modulo len 256))))
	 ((< len most-positive-fixnum)
	  (list (C 255)
		(C (quotient len (* 256 256 256)))
		(C (modulo (quotient len (* 256 256)) 256))
		(C (modulo (quotient len 256) 256))
		(C (modulo len 256))))
	 (else (error "Too long" len)))))

(define (code->bytes code)
  (let* ((code (list->vector code))
	 (size (vector-length code)))
    (let loop ((i 0))
      (if (>= i size)
	  (apply string-append (vector->list code))
	  (let ((inst (vector-ref code i)))
	    (if (not (instruction? inst))
		(error "Unknown instruction:" inst))
	    (vector-set! code i (integer->string (instruction->opcode inst)))
	    (let ((bytes (instruction-length inst)))
	      (cond ((< bytes 0)
		     (vector-set! code i
				  (integer->string (instruction->opcode inst)))
		     (vector-set! code (+ i 1)
				  (length->string (vector-ref code (1+ i))))
		     (loop (+ i 3)))
		    ((= bytes 0) (loop (+ i 1)))
		    (else
		     (let ((end (+ i 1 bytes)))
		       (do ((j (+ i 1) (1+ j)))
			   ((= j end) (loop end))
			 (vector-set! code j (integer->string
					      (vector-ref code j)))))))))))))
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)
	33	(dump (codegen (preprocess glil #f) #t)))
	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))
	44	(define-structure (bytespec nargs nrest nlocs bytes objs))
	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 '())
	75	(object-alist '())
	76	(nvars (+ nargs nlocs -1)))
	77	(define (current-address) (length stack))
	78	(define (push-code! code)
	79	(set! stack (optimizing-push code stack)))
	80	(define (object-index obj)
	81	(cond ((assq-ref object-alist obj))
	82	(else (let ((index (length object-alist)))
	83	(set! object-alist (acons obj index object-alist))
	84	index))))
	85	(define (label-ref key)
	86	(assq-ref label-alist key))
	87	(define (label-set key pos)
88	(set! label-alist (assq-set! label-alist key pos)))
89	(define (generate-code x)
90	(match x
91	(($ <vm-asm> env)
92	(push-code! `(object-ref ,(object-index (codegen x #f))))
93	(if (venv-closure? env) (push-code! `(make-closure))))
94
95	(($ <glil-void>)
96	(push-code! `(void)))
97
98	(($ <glil-const> x)
99	(if toplevel
100	(for-each push-code! (object->dump-code x))
101	(cond ((object->code x) => push-code!)
102	(else (push-code! `(object-ref ,(object-index x)))))))
103
104	(($ <glil-argument> op index)
105	(push-code! (list (symbol-append 'local- op)
106	(- nvars index))))
107
108	(($ <glil-local> op index)
109	(push-code! (list (symbol-append 'local- op)
110	(- nvars (+ nargs index)))))
111
112	(($ <glil-external> op depth index)
113	(do ((e venv (venv-parent e))
114	(d depth (1- d))
115	(i 0 (+ i (venv-nexts e))))
116	((= d 0)
117	(push-code! (list (symbol-append 'external- op)
118	(+ index i))))))
119
120	(($ <glil-module> op module name)
d4ae3ae6 KN	121	(if toplevel
	122	(begin
	123	;; (push-code! `(load-module ,module))
	124	(push-code! `(load-symbol ,name))
	125	(push-code! `(link/current-module)))
	126	;; (let ((vlink (make-vlink (make-vmod module) name)))
	127	(let ((vlink (make-vlink #f name)))
	128	(push-code! `(object-ref ,(object-index vlink)))))
	129	(push-code! (list (symbol-append 'variable- op))))
17e90c5e KN	130
	131	(($ <glil-label> label)
	132	(label-set label (current-address)))
	133
	134	(($ <glil-branch> inst label)
	135	(let ((setter (lambda (addr) (- (label-ref label) (1+ addr)))))
	136	(push-code! (list inst setter))))
	137
46cd9a34	138	(($ <glil-call> inst nargs)
17e90c5e	139	(if (instruction? inst)
46cd9a34 KN	140	(let ((pops (instruction-pops inst)))
	141	(cond ((< pops 0)
	142	(push-code! (list inst nargs)))
	143	((= pops nargs)
	144	(push-code! (list inst)))
	145	(else
	146	(error "Wrong number of arguments:" inst nargs))))
17e90c5e KN	147	(error "Unknown instruction:" inst)))))
	148	;;
	149	;; main
	150	(if (> nexts 0) (push-code! `(external ,nexts)))
	151	(for-each generate-code body)
	152	(let ((bytes (code->bytes
	153	(map/index (lambda (v n) (if (procedure? v) (v n) v))
	154	(reverse! stack))))
	155	(objs (map car (reverse! object-alist))))
	156	(make-bytespec nargs nrest nlocs bytes objs))))))
	157
	158	(define (map/index f l)
	159	(do ((n 0 (1+ n))
	160	(l l (cdr l))
	161	(r '() (cons (f (car l) n) r)))
	162	((null? l) (reverse! r))))
	163
	164	;; Optimization
	165
	166	(define optimize-table
	167	'((not (not . not-not)
	168	(eq? . not-eq?)
	169	(null? . not-null?)
	170	(not-not . not)
	171	(not-eq? . eq?)
	172	(not-null? . null?))
	173	(br-if (not . br-if-not)
	174	(eq? . br-if-eq)
	175	(null? . br-if-null)
	176	(not-not . br-if)
	177	(not-eq? . br-if-not-eq)
	178	(not-null? . br-if-not-null))
	179	(br-if-not (not . br-if)
	180	(eq? . br-if-not-eq)
	181	(null? . br-if-not-null)
	182	(not-not . br-if-not)
	183	(not-eq? . br-if-eq)
	184	(not-null? . br-if-null))))
	185
	186	(define (optimizing-push code stack)
	187	(let ((alist (assq-ref optimize-table (car code))))
	188	(cond ((and alist (pair? stack) (assq-ref alist (car stack))) =>
	189	(lambda (inst) (append! (reverse! (cons inst (cdr code)))
	190	(cdr stack))))
	191	(else (append! (reverse! (code-finalize code)) stack)))))
	192
	193	\f
	194	;;;
	195	;;; Stage3: Dumpcode generation
	196	;;;
	197
	198	(define (dump bytespec)
	199	(let* ((table (build-object-table bytespec))
	200	(bytes (bytespec->bytecode bytespec table '(return))))
	201	(if (null? table)
	202	bytes
	203	(let ((spec (make-bytespec 0 0 (length table) bytes '())))
	204	(bytespec->bytecode spec '() '(tail-call 0))))))
	205
	206	(define (bytespec->bytecode bytespec object-table last-code)
	207	(let ((stack '()))
	208	(define (push-code! x)
	209	(set! stack (cons x stack)))
	210	(define (object-index x)
211	(cond ((object-find object-table x) => cdr)
212	(else #f)))
213	(define (dump-table-object! obj+index)
214	(let dump! ((x (car obj+index)))
215	(cond
216	((vlink? x)
fdcedea6	217	;; (push-code! `(local-ref ,(object-index (vlink-module x))))
17e90c5e	218	(push-code! `(load-symbol ,(vlink-name x)))
fdcedea6	219	(push-code! `(link/current-module)))
17e90c5e KN	220	((vmod? x)
	221	(push-code! `(load-module ,(vmod-id x))))
	222	(else
	223	(for-each push-code! (object->dump-code x)))))
	224	(push-code! `(local-set ,(cdr obj+index))))
	225	(define (dump-object! x)
	226	(let dump! ((x x))
	227	(cond
	228	((bytespec? x) (dump-bytecode! x))
	229	((object-index x) => (lambda (i) (push-code! `(local-ref ,i))))
	230	(else
	231	(error "Cannot dump:" x)))))
	232	(define (dump-bytecode! spec)
	233	(let ((nargs (bytespec-nargs spec))
	234	(nrest (bytespec-nrest spec))
	235	(nlocs (bytespec-nlocs spec))
	236	(objs (bytespec-objs spec)))
	237	(if (and (null? objs) (< nargs 4) (< nlocs 16))
	238	;; zero-object encoding
	239	(push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
	240	(begin
	241	;; dump parameters
	242	(push-code! (object->code nargs))
	243	(push-code! (object->code nrest))
	244	(push-code! (object->code nlocs))
	245	;; dump object table
	246	(cond ((null? objs) (push-code! (object->code #f)))
	247	(else
17e90c5e	248	(for-each dump-object! objs)
46cd9a34	249	(push-code! `(vector ,(length objs)))))))
17e90c5e KN	250	;; dump bytecode
	251	(push-code! `(load-program ,(bytespec-bytes spec)))))
	252	;;
	253	;; main
	254	(for-each dump-table-object! object-table)
	255	(dump-bytecode! bytespec)
	256	(push-code! last-code)
	257	(code->bytes (apply append! (map code-finalize (reverse! stack))))))
	258
	259	;; object table
	260
	261	(define (object-find table x)
	262	((if (or (vlink? x) (vmod? x)) assoc assq) x table))
	263
	264	(define (build-object-table bytespec)
	265	(let ((table '()) (index 0))
	266	(define (insert! x)
d4ae3ae6	267	;; (if (vlink? x) (begin (insert! (vlink-module x))))
17e90c5e KN	268	(if (not (object-find table x))
	269	(begin
	270	(set! table (acons x index table))
	271	(set! index (1+ index)))))
	272	(let loop ((spec bytespec))
	273	(for-each (lambda (x)
	274	(if (bytespec? x) (loop x) (insert! x)))
	275	(bytespec-objs spec)))
	276	(reverse! table)))
	277
	278	;; code generation
	279
	280	(define (code-finalize code)
	281	(match code
	282	((inst (? symbol? s))
ea9b4b29 KN	283	(let ((s (symbol->string s)))
ea9b4b29 KN	284	`(,inst ,(string-length s) ,s)))
17e90c5e KN	285	((inst (? string? s))
	286	`(,inst ,(string-length s) ,s))
	287	(else (code-pack code))))
	288
	289	(define (integer->string n) (make-string 1 (integer->char n)))
	290
	291	(define (length->string len)
	292	(define C integer->char)
	293	(list->string
	294	(cond ((< len 254) (list (C len)))
	295	((< len 65536)
	296	(list (C 254) (C (quotient len 256)) (C (modulo len 256))))
	297	((< len most-positive-fixnum)
	298	(list (C 255)
	299	(C (quotient len (* 256 256 256)))
	300	(C (modulo (quotient len (* 256 256)) 256))
	301	(C (modulo (quotient len 256) 256))
	302	(C (modulo len 256))))
	303	(else (error "Too long" len)))))
	304
	305	(define (code->bytes code)
	306	(let* ((code (list->vector code))
	307	(size (vector-length code)))
	308	(let loop ((i 0))
	309	(if (>= i size)
	310	(apply string-append (vector->list code))
	311	(let ((inst (vector-ref code i)))
	312	(if (not (instruction? inst))
	313	(error "Unknown instruction:" inst))
	314	(vector-set! code i (integer->string (instruction->opcode inst)))
	315	(let ((bytes (instruction-length inst)))
	316	(cond ((< bytes 0)
	317	(vector-set! code i
	318	(integer->string (instruction->opcode inst)))
	319	(vector-set! code (+ i 1)
	320	(length->string (vector-ref code (1+ i))))
	321	(loop (+ i 3)))
	322	((= bytes 0) (loop (+ i 1)))
	323	(else
	324	(let ((end (+ i 1 bytes)))
	325	(do ((j (+ i 1) (1+ j)))
	326	((= j end) (loop end))
	327	(vector-set! code j (integer->string
	328	(vector-ref code j)))))))))))))