[bpt/guile.git] / module / system / il / compile.scm

;;; GHIL -> GLIL compiler

;; 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 il compile)
  :use-module (oop goops)
  :use-syntax (system base syntax)
  :use-module (system il glil)
  :use-module (system il ghil)
  :use-module (ice-9 match)
  :use-module (ice-9 common-list)
  :export (compile))

(define (compile x e . opts)
  (if (memq :O opts) (set! x (optimize x)))
  (codegen x))

\f
;;;
;;; Stage 2: Optimization
;;;

(define (optimize x)
  (match x
    (($ <ghil-set> env var val)
     (make-<ghil-set> env var (optimize val)))

    (($ <ghil-if> test then else)
     (make-<ghil-if> (optimize test) (optimize then) (optimize else)))

    (($ <ghil-begin> exps)
     (make-<ghil-begin> (map optimize exps)))

    (($ <ghil-bind> env vars vals body)
     (make-<ghil-bind> env vars (map optimize vals) (optimize body)))

    (($ <ghil-lambda> env vars rest body)
     (make-<ghil-lambda> env vars rest (optimize body)))

    (($ <ghil-inst> inst args)
     (make-<ghil-inst> inst (map optimize args)))

    (($ <ghil-call> env proc args)
     (match proc
       ;; ((@lambda (VAR...) BODY...) ARG...) =>
       ;;   (@let ((VAR ARG) ...) BODY...)
       (($ <ghil-lambda> lambda-env vars #f body)
	(for-each (lambda (v)
		    (if (eq? v.kind 'argument) (set! v.kind 'local))
		    (set! v.env env)
		    (ghil-env-add! env v))
		  lambda-env.variables)
	(optimize (make-<ghil-bind> env vars args body)))
       (else
	(make-<ghil-call> env (optimize proc) (map optimize args)))))
    (else x)))

\f
;;;
;;; Stage 3: Code generation
;;;

(define *ia-void* (make-<glil-void>))
(define *ia-drop* (make-<glil-call> 'drop 0))
(define *ia-return* (make-<glil-call> 'return 0))

(define (make-label) (gensym ":L"))

(define (make-glil-var op env var)
  (case var.kind
    ((argument)
     (make-<glil-argument> op var.index))
    ((local)
     (make-<glil-local> op var.index))
    ((external)
     (do ((depth 0 (1+ depth))
	  (e env e.parent))
	 ((eq? e var.env)
	  (make-<glil-external> op depth var.index))))
    ((module)
     (make-<glil-module> op var.env var.name))
    (else (error "Unknown kind of variable:" var))))

(define (codegen ghil)
  (let ((stack '()))
    (define (push-code! code)
      (set! stack (cons code stack)))
    (define (comp tree tail drop)
      (define (push-label! label)
	(push-code! (make-<glil-label> label)))
      (define (push-branch! inst label)
	(push-code! (make-<glil-branch> inst label)))
      (define (push-call! inst args)
	(for-each comp-push args)
	(push-code! (make-<glil-call> inst (length args))))
      ;; possible tail position
      (define (comp-tail tree) (comp tree tail drop))
      ;; push the result
      (define (comp-push tree) (comp tree #f #f))
      ;; drop the result
      (define (comp-drop tree) (comp tree #f #t))
      ;; drop the result if unnecessary
      (define (maybe-drop)
	(if drop (push-code! *ia-drop*)))
      ;; return here if necessary
      (define (maybe-return)
	(if tail (push-code! *ia-return*)))
      ;; return this code if necessary
      (define (return-code! code)
	(if (not drop) (push-code! code))
	(maybe-return))
      ;; return void if necessary
      (define (return-void!)
	(return-code! *ia-void*))
      ;; return object if necessary
      (define (return-object! obj)
	(return-code! (make-<glil-const> obj)))
      ;;
      ;; dispatch
      (match tree
	(($ <ghil-void>)
	 (return-void!))

	(($ <ghil-quote> env loc obj)
	 (return-object! obj))

	(($ <ghil-quasiquote> env loc exp)
	 (let loop ((x exp))
	   (match x
	     ((? list? ls)
	      (push-call! 'mark '())
	      (for-each loop ls)
	      (push-call! 'list-mark '()))
	     ((? pair? pp)
	      (loop (car pp))
	      (loop (cdr pp))
	      (push-code! (make-<glil-call> 'cons 2)))
	     (($ <ghil-unquote> env loc exp)
	      (comp-push exp))
	     (($ <ghil-unquote-splicing> env loc exp)
	      (comp-push exp)
	      (push-call! 'list-break '()))
	     (else
	      (push-code! (make-<glil-const> x)))))
	 (maybe-drop)
	 (maybe-return))

	(($ <ghil-ref> env loc var)
	 (return-code! (make-glil-var 'ref env var)))

	((or ($ <ghil-set> env loc var val)
	     ($ <ghil-define> env loc var val))
	 (comp-push val)
	 (push-code! (make-glil-var 'set env var))
	 (return-void!))

	(($ <ghil-if> env loc test then else)
	 ;;     TEST
	 ;;     (br-if-not L1)
	 ;;     THEN
	 ;;     (br L2)
	 ;; L1: ELSE
	 ;; L2:
	 (let ((L1 (make-label)) (L2 (make-label)))
	   (comp-push test)
	   (push-branch! 'br-if-not L1)
	   (comp-tail then)
	   (if (not tail) (push-branch! 'br L2))
	   (push-label! L1)
	   (comp-tail else)
	   (if (not tail) (push-label! L2))))

	(($ <ghil-and> env loc exps)
	 ;;     EXP
	 ;;     (br-if-not L1)
	 ;;     ...
	 ;;     TAIL
	 ;;     (br L2)
	 ;; L1: (const #f)
	 ;; L2:
	 (let ((L1 (make-label)) (L2 (make-label)))
	   (if (null? exps)
	       (return-object! #t)
	       (do ((exps exps (cdr exps)))
		   ((null? (cdr exps))
		    (comp-tail (car exps))
		    (if (not tail) (push-branch! 'br L2))
		    (push-label! L1)
		    (return-object! #f)
		    (if (not tail) (push-label! L2))
		    (maybe-drop)
		    (maybe-return))
		 (comp-push (car exps))
		 (push-branch! 'br-if-not L1)))))

	(($ <ghil-or> env loc exps)
	 ;;     EXP
	 ;;     (dup)
	 ;;     (br-if L1)
	 ;;     (drop)
	 ;;     ...
	 ;;     TAIL
	 ;; L1:
	 (let ((L1 (make-label)))
	   (if (null? exps)
	       (return-object! #f)
	       (do ((exps exps (cdr exps)))
		   ((null? (cdr exps))
		    (comp-tail (car exps))
		    (push-label! L1)
		    (maybe-drop)
		    (maybe-return))
		 (comp-push (car exps))
		 (push-call! 'dup '())
		 (push-branch! 'br-if L1)
		 (push-call! 'drop '())))))

	(($ <ghil-begin> env loc exps)
	 ;; EXPS...
	 ;; TAIL
	 (if (null? exps)
	     (return-void!)
	     (do ((exps exps (cdr exps)))
		 ((null? (cdr exps))
		  (comp-tail (car exps)))
	       (comp-drop (car exps)))))

	(($ <ghil-bind> env loc vars vals body)
	 ;; VALS...
	 ;; (set VARS)...
	 ;; BODY
	 (for-each comp-push vals)
	 (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
		   (reverse vars))
	 (comp-tail body))

	(($ <ghil-lambda> env loc vars rest body)
	 (return-code! (codegen tree)))

	(($ <ghil-inline> env loc inst args)
	 ;; ARGS...
	 ;; (INST NARGS)
	 (push-call! inst args)
	 (maybe-drop)
	 (maybe-return))

	(($ <ghil-call> env loc proc args)
	 ;; PROC
	 ;; ARGS...
	 ;; ([tail-]call NARGS)
	 (comp-push proc)
	 (push-call! (if tail 'tail-call 'call) args)
	 (maybe-drop))))
    ;;
    ;; main
    (match ghil
      (($ <ghil-lambda> env loc args rest body)
       (let* ((vars env.variables)
	      (locs (pick (lambda (v) (eq? v.kind 'local)) vars))
	      (exts (pick (lambda (v) (eq? v.kind 'external)) vars)))
	 ;; initialize variable indexes
	 (finalize-index! args)
	 (finalize-index! locs)
	 (finalize-index! exts)
	 ;; export arguments
	 (do ((n 0 (1+ n)) (l args (cdr l)))
	     ((null? l))
	   (let ((v (car l)))
	     (if (eq? v.kind 'external)
		 (begin (push-code! (make-<glil-argument> 'ref n))
			(push-code! (make-<glil-external> 'set 0 v.index))))))
	 ;; compile body
	 (comp body #t #f)
	 ;; create GLIL
	 (make-<glil-asm> (length args) (if rest 1 0) (length locs)
			  (length exts) (reverse! stack)))))))

(define (finalize-index! list)
  (do ((n 0 (1+ n))
       (l list (cdr l)))
      ((null? l))
    (let ((v (car l))) (set! v.index n))))
Commit	Line	Data
17e90c5e KN	1	;;; GHIL -> GLIL compiler
	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 il compile)
	23	:use-module (oop goops)
	24	:use-syntax (system base syntax)
17e90c5e KN	25	:use-module (system il glil)
17e90c5e KN	26	:use-module (system il ghil)
cb4cca12	27	:use-module (ice-9 match)
17e90c5e KN	28	:use-module (ice-9 common-list)
	29	:export (compile))
	30
	31	(define (compile x e . opts)
17e90c5e KN	32	(if (memq :O opts) (set! x (optimize x)))
	33	(codegen x))
	34
	35	\f
	36	;;;
	37	;;; Stage 2: Optimization
	38	;;;
	39
	40	(define (optimize x)
	41	(match x
3616e9e9 KN	42	(($ <ghil-set> env var val)
	43	(make-<ghil-set> env var (optimize val)))
	44
	45	(($ <ghil-if> test then else)
	46	(make-<ghil-if> (optimize test) (optimize then) (optimize else)))
	47
	48	(($ <ghil-begin> exps)
	49	(make-<ghil-begin> (map optimize exps)))
	50
	51	(($ <ghil-bind> env vars vals body)
	52	(make-<ghil-bind> env vars (map optimize vals) (optimize body)))
	53
	54	(($ <ghil-lambda> env vars rest body)
	55	(make-<ghil-lambda> env vars rest (optimize body)))
	56
	57	(($ <ghil-inst> inst args)
	58	(make-<ghil-inst> inst (map optimize args)))
	59
	60	(($ <ghil-call> env proc args)
17e90c5e KN	61	(match proc
	62	;; ((@lambda (VAR...) BODY...) ARG...) =>
	63	;; (@let ((VAR ARG) ...) BODY...)
3616e9e9 KN	64	(($ <ghil-lambda> lambda-env vars #f body)
	65	(for-each (lambda (v)
	66	(if (eq? v.kind 'argument) (set! v.kind 'local))
c0a25ecc	67	(set! v.env env)
3616e9e9 KN	68	(ghil-env-add! env v))
	69	lambda-env.variables)
	70	(optimize (make-<ghil-bind> env vars args body)))
17e90c5e	71	(else
3616e9e9	72	(make-<ghil-call> env (optimize proc) (map optimize args)))))
17e90c5e KN	73	(else x)))
	74
	75	\f
	76	;;;
	77	;;; Stage 3: Code generation
	78	;;;
	79
	80	(define ia-void (make-<glil-void>))
46cd9a34 KN	81	(define ia-drop (make-<glil-call> 'drop 0))
46cd9a34 KN	82	(define ia-return (make-<glil-call> 'return 0))
17e90c5e KN	83
	84	(define (make-label) (gensym ":L"))
	85
	86	(define (make-glil-var op env var)
	87	(case var.kind
	88	((argument)
	89	(make-<glil-argument> op var.index))
	90	((local)
	91	(make-<glil-local> op var.index))
	92	((external)
	93	(do ((depth 0 (1+ depth))
	94	(e env e.parent))
	95	((eq? e var.env)
	96	(make-<glil-external> op depth var.index))))
	97	((module)
	98	(make-<glil-module> op var.env var.name))
	99	(else (error "Unknown kind of variable:" var))))
	100
	101	(define (codegen ghil)
	102	(let ((stack '()))
	103	(define (push-code! code)
	104	(set! stack (cons code stack)))
	105	(define (comp tree tail drop)
cb4cca12 KN	106	(define (push-label! label)
	107	(push-code! (make-<glil-label> label)))
	108	(define (push-branch! inst label)
	109	(push-code! (make-<glil-branch> inst label)))
	110	(define (push-call! inst args)
	111	(for-each comp-push args)
	112	(push-code! (make-<glil-call> inst (length args))))
17e90c5e KN	113	;; possible tail position
	114	(define (comp-tail tree) (comp tree tail drop))
	115	;; push the result
	116	(define (comp-push tree) (comp tree #f #f))
	117	;; drop the result
	118	(define (comp-drop tree) (comp tree #f #t))
cb4cca12 KN	119	;; drop the result if unnecessary
	120	(define (maybe-drop)
	121	(if drop (push-code! ia-drop)))
	122	;; return here if necessary
	123	(define (maybe-return)
	124	(if tail (push-code! ia-return)))
17e90c5e KN	125	;; return this code if necessary
	126	(define (return-code! code)
	127	(if (not drop) (push-code! code))
cb4cca12	128	(maybe-return))
17e90c5e	129	;; return void if necessary
cb4cca12 KN	130	(define (return-void!)
	131	(return-code! ia-void))
	132	;; return object if necessary
	133	(define (return-object! obj)
	134	(return-code! (make-<glil-const> obj)))
17e90c5e KN	135	;;
	136	;; dispatch
	137	(match tree
	138	(($ <ghil-void>)
	139	(return-void!))
	140
cb4cca12 KN	141	(($ <ghil-quote> env loc obj)
	142	(return-object! obj))
	143
	144	(($ <ghil-quasiquote> env loc exp)
	145	(let loop ((x exp))
	146	(match x
	147	((? list? ls)
	148	(push-call! 'mark '())
	149	(for-each loop ls)
	150	(push-call! 'list-mark '()))
	151	((? pair? pp)
	152	(loop (car pp))
	153	(loop (cdr pp))
	154	(push-code! (make-<glil-call> 'cons 2)))
	155	(($ <ghil-unquote> env loc exp)
	156	(comp-push exp))
	157	(($ <ghil-unquote-splicing> env loc exp)
	158	(comp-push exp)
	159	(push-call! 'list-break '()))
	160	(else
	161	(push-code! (make-<glil-const> x)))))
	162	(maybe-drop)
	163	(maybe-return))
17e90c5e	164
cb4cca12	165	(($ <ghil-ref> env loc var)
17e90c5e KN	166	(return-code! (make-glil-var 'ref env var)))
17e90c5e KN	167
cb4cca12 KN	168	((or ($ <ghil-set> env loc var val)
cb4cca12 KN	169	($ <ghil-define> env loc var val))
17e90c5e KN	170	(comp-push val)
	171	(push-code! (make-glil-var 'set env var))
	172	(return-void!))
	173
cb4cca12	174	(($ <ghil-if> env loc test then else)
17e90c5e KN	175	;; TEST
	176	;; (br-if-not L1)
	177	;; THEN
41f248a8	178	;; (br L2)
17e90c5e KN	179	;; L1: ELSE
	180	;; L2:
	181	(let ((L1 (make-label)) (L2 (make-label)))
	182	(comp-push test)
cb4cca12	183	(push-branch! 'br-if-not L1)
17e90c5e	184	(comp-tail then)
cb4cca12 KN	185	(if (not tail) (push-branch! 'br L2))
cb4cca12 KN	186	(push-label! L1)
17e90c5e	187	(comp-tail else)
cb4cca12 KN	188	(if (not tail) (push-label! L2))))
	189
	190	(($ <ghil-and> env loc exps)
	191	;; EXP
	192	;; (br-if-not L1)
	193	;; ...
	194	;; TAIL
	195	;; (br L2)
	196	;; L1: (const #f)
	197	;; L2:
	198	(let ((L1 (make-label)) (L2 (make-label)))
	199	(if (null? exps)
	200	(return-object! #t)
	201	(do ((exps exps (cdr exps)))
	202	((null? (cdr exps))
	203	(comp-tail (car exps))
	204	(if (not tail) (push-branch! 'br L2))
	205	(push-label! L1)
	206	(return-object! #f)
	207	(if (not tail) (push-label! L2))
	208	(maybe-drop)
	209	(maybe-return))
	210	(comp-push (car exps))
	211	(push-branch! 'br-if-not L1)))))
	212
	213	(($ <ghil-or> env loc exps)
	214	;; EXP
	215	;; (dup)
	216	;; (br-if L1)
	217	;; (drop)
	218	;; ...
	219	;; TAIL
	220	;; L1:
	221	(let ((L1 (make-label)))
	222	(if (null? exps)
	223	(return-object! #f)
	224	(do ((exps exps (cdr exps)))
	225	((null? (cdr exps))
	226	(comp-tail (car exps))
	227	(push-label! L1)
	228	(maybe-drop)
	229	(maybe-return))
	230	(comp-push (car exps))
	231	(push-call! 'dup '())
	232	(push-branch! 'br-if L1)
	233	(push-call! 'drop '())))))
17e90c5e	234
cb4cca12	235	(($ <ghil-begin> env loc exps)
17e90c5e KN	236	;; EXPS...
	237	;; TAIL
	238	(if (null? exps)
	239	(return-void!)
	240	(do ((exps exps (cdr exps)))
	241	((null? (cdr exps))
	242	(comp-tail (car exps)))
	243	(comp-drop (car exps)))))
	244
cb4cca12	245	(($ <ghil-bind> env loc vars vals body)
17e90c5e KN	246	;; VALS...
	247	;; (set VARS)...
	248	;; BODY
	249	(for-each comp-push vals)
	250	(for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
	251	(reverse vars))
	252	(comp-tail body))
	253
cb4cca12	254	(($ <ghil-lambda> env loc vars rest body)
17e90c5e KN	255	(return-code! (codegen tree)))
17e90c5e KN	256
cb4cca12	257	(($ <ghil-inline> env loc inst args)
46cd9a34 KN	258	;; ARGS...
46cd9a34 KN	259	;; (INST NARGS)
cb4cca12 KN	260	(push-call! inst args)
	261	(maybe-drop)
	262	(maybe-return))
46cd9a34	263
cb4cca12	264	(($ <ghil-call> env loc proc args)
17e90c5e	265	;; PROC
3616e9e9	266	;; ARGS...
17e90c5e	267	;; ([tail-]call NARGS)
17e90c5e	268	(comp-push proc)
cb4cca12 KN	269	(push-call! (if tail 'tail-call 'call) args)
cb4cca12 KN	270	(maybe-drop))))
17e90c5e KN	271	;;
	272	;; main
	273	(match ghil
cb4cca12	274	(($ <ghil-lambda> env loc args rest body)
17e90c5e KN	275	(let* ((vars env.variables)
	276	(locs (pick (lambda (v) (eq? v.kind 'local)) vars))
	277	(exts (pick (lambda (v) (eq? v.kind 'external)) vars)))
	278	;; initialize variable indexes
	279	(finalize-index! args)
	280	(finalize-index! locs)
	281	(finalize-index! exts)
	282	;; export arguments
	283	(do ((n 0 (1+ n)) (l args (cdr l)))
	284	((null? l))
	285	(let ((v (car l)))
	286	(if (eq? v.kind 'external)
	287	(begin (push-code! (make-<glil-argument> 'ref n))
	288	(push-code! (make-<glil-external> 'set 0 v.index))))))
	289	;; compile body
	290	(comp body #t #f)
	291	;; create GLIL
	292	(make-<glil-asm> (length args) (if rest 1 0) (length locs)
	293	(length exts) (reverse! stack)))))))
	294
	295	(define (finalize-index! list)
	296	(do ((n 0 (1+ n))
	297	(l list (cdr l)))
	298	((null? l))
	299	(let ((v (car l))) (set! v.index n))))