: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)
- (set! x (parse-ghil x e))
(if (memq :O opts) (set! x (optimize x)))
(codegen x))
(define (optimize x)
(match x
- (($ <ghil-call> proc args)
+ (($ <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> env vars #f body)
- (optimize (make-<ghil-bind> vars args 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> (optimize proc) (for-each optimize args)))))
+ (make-<ghil-call> env (optimize proc) (map optimize args)))))
(else x)))
\f
;;;
(define *ia-void* (make-<glil-void>))
-(define *ia-drop* (make-<glil-inst> 'drop))
-(define *ia-return* (make-<glil-inst> 'return))
+(define *ia-drop* (make-<glil-call> 'drop 0))
+(define *ia-return* (make-<glil-call> 'return 0))
(define (make-label) (gensym ":L"))
(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))
- (if tail (push-code! *ia-return*)))
+ (maybe-return))
;; return void if necessary
- (define (return-void!) (return-code! *ia-void*))
+ (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> obj)
- (return-code! (make-<glil-const> obj)))
+ (($ <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 var)
+ (($ <ghil-ref> env loc var)
(return-code! (make-glil-var 'ref env var)))
- (($ <ghil-set> env var val)
+ ((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> test then else)
+ (($ <ghil-if> env loc test then else)
;; TEST
;; (br-if-not L1)
;; THEN
- ;; (jump L2)
+ ;; (br L2)
;; L1: ELSE
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(comp-push test)
- (push-code! (make-<glil-branch> 'br-if-not L1))
+ (push-branch! 'br-if-not L1)
(comp-tail then)
- (if (not tail) (push-code! (make-<glil-branch> 'jump L2)))
- (push-code! (make-<glil-label> L1))
+ (if (not tail) (push-branch! 'br L2))
+ (push-label! L1)
(comp-tail else)
- (if (not tail) (push-code! (make-<glil-label> L2)))))
+ (if (not tail) (push-label! L2))))
- (($ <ghil-begin> exps)
+ (($ <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)
(comp-tail (car exps)))
(comp-drop (car exps)))))
- (($ <ghil-bind> env vars vals body)
+ (($ <ghil-bind> env loc vars vals body)
;; VALS...
;; (set VARS)...
;; BODY
(reverse vars))
(comp-tail body))
- (($ <ghil-lambda> vars rest body)
+ (($ <ghil-lambda> env loc vars rest body)
(return-code! (codegen tree)))
- (($ <ghil-call> proc args)
+ (($ <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)
- (for-each comp-push args)
(comp-push proc)
- (let ((inst (if tail 'tail-call 'call)))
- (push-code! (make-<glil-call> inst (length args))))
- (if drop (push-code! *ia-drop*)))
-
- (($ <ghil-inst> inst args)
- ;; ARGS...
- ;; (INST)
- (for-each comp-push args)
- (push-code! (make-<glil-inst> inst))
- (if drop (push-code! *ia-drop*))
- (if tail (push-code! *ia-return*)))))
+ (push-call! (if tail 'tail-call 'call) args)
+ (maybe-drop))))
;;
;; main
(match ghil
- (($ <ghil-lambda> env args rest body)
+ (($ <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)))
(finalize-index! locs)
(finalize-index! exts)
;; export arguments
- (do ((n 0 (1+ n)) (l args (cdr l)))
+ (do ((n 0 (1+ n))
+ (l args (cdr l)))
((null? l))
(let ((v (car l)))
(if (eq? v.kind 'external)
HCoop / bpt / guile.git / blobdiff