ikarus/src/libcogen1.ss

425 lines
12 KiB
Scheme

#!eof
;;; input to cogen is <Program>:
;;; <Expr> ::= (constant x)
;;; | (var)
;;; | (primref name)
;;; | (bind var* <Expr>* <Expr>)
;;; | (fix var* <FixRhs>* <Expr>)
;;; | (conditional <Expr> <Expr> <Expr>)
;;; | (seq <Expr> <Expr>)
;;; | (closure <codeloc> <var>*) ; thunk special case
;;; | (primcall op <Expr>*)
;;; | (forcall "name" <Expr>*)
;;; | (funcall <Expr> <Expr>*)
;;; | (jmpcall <label> <Expr> <Expr>*)
;;; | (appcall <Expr> <Expr>*)
;;; | (mvcall <Expr> <clambda>)
;;; <codeloc> ::= (code-loc <label>)
;;; <clambda> ::= (clambda <label> <case>* <free var>*)
;;; <case> ::= (clambda-case <info> <body>)
;;; <info> ::= (clambda-info label <arg var>* proper)
;;; <Program> ::= (codes <clambda>* <Expr>)
(define (verify-new-cogen-input x)
;;;
(define who 'verify-new-cogen-input)
;;;
(define (check-gensym x)
(unless (gensym? x)
(error who "invalid gensym ~s" x)))
;;;
(define (check-label x)
(record-case x
[(code-loc label)
(check-gensym label)]
[else (error who "invalid label ~s" x)]))
;;;
(define (check-var x)
(record-case x
[(var) (void)]
[else (error who "invalid var ~s" x)]))
;;;
(define (check-closure x)
(record-case x
[(closure label free*)
(check-label label)
(for-each check-var free*)]
[else (error who "invalid closure ~s" x)]))
;;;
(define (Expr x)
(record-case x
[(constant) (void)]
[(var) (void)]
[(primref) (void)]
[(bind lhs* rhs* body)
(for-each check-var lhs*)
(for-each Expr rhs*)
(Expr body)]
[(fix lhs* rhs* body)
(for-each check-var lhs*)
(for-each check-closure rhs*)
(Expr body)]
[(conditional e0 e1 e2)
(Expr e0) (Expr e1) (Expr e2)]
[(seq e0 e1)
(Expr e0) (Expr e1)]
[(closure) (check-closure x)]
[(primcall op arg*)
(for-each Expr arg*)]
[(forcall op arg*)
(for-each Expr arg*)]
[(funcall rator arg*)
(Expr rator)
(for-each Expr arg*)]
[(jmpcall label rator arg*)
(check-gensym label)
(Expr rator)
(for-each Expr arg*)]
[(appcall rator arg*)
(Expr rator)
(for-each Expr arg*)]
[(mvcall rator k)
(Expr rator)
(Clambda k)]
[else (error who "invalid expr ~s" x)]))
;;;
(define (check-info x)
(record-case x
[(case-info label args proper)
(check-gensym label)
(for-each check-var args)]
[else (error who "invalid case-info ~s" x)]))
;;;
(define (ClambdaCase x)
(record-case x
[(clambda-case info body)
(check-info info)
(Expr body)]
[else (error who "invalid clambda-case ~s" x)]))
;;;
(define (Clambda x)
(record-case x
[(clambda label case* free*)
(for-each check-var free*)
(for-each ClambdaCase case*)
(check-gensym label)]
[else (error who "invalid clambda ~s" x)]))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(for-each Clambda code*)
(Expr body)]
[else (error who "invalid program ~s" x)]))
;;;
(Program x))
;;; the program so far includes both primcalls and funcalls to
;;; primrefs. This pass removes all primcalls. Once everything
;;; works, we need to fix all previous passes to eliminate this
;;; whole primcall business.
(define (remove-primcalls x)
;;;
(define who 'remove-primcalls)
;;;
(define (check-gensym x)
(unless (gensym? x)
(error who "invalid gensym ~s" x)))
;;;
(define (check-label x)
(record-case x
[(code-loc label)
(check-gensym label)]
[else (error who "invalid label ~s" x)]))
;;;
(define (check-var x)
(record-case x
[(var) (void)]
[else (error who "invalid var ~s" x)]))
;;;
(define (check-closure x)
(record-case x
[(closure label free*)
(check-label label)
(for-each check-var free*)]
[else (error who "invalid closure ~s" x)]))
;;;
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(make-fix lhs* rhs* (Expr body))]
[(conditional e0 e1 e2)
(make-conditional (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(closure) x]
[(primcall op arg*)
(make-appcall (make-primref op) (map Expr arg*))]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
(make-funcall (Expr rator) (map Expr arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(appcall rator arg*)
(error 'new-cogen "appcall not supported yet")
(make-appcall (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr ~s" x)]))
;;;
(define (ClambdaCase x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]
[else (error who "invalid clambda-case ~s" x)]))
;;;
(define (Clambda x)
(record-case x
[(clambda label case* free*)
(make-clambda label (map ClambdaCase case*) free*)]
[else (error who "invalid clambda ~s" x)]))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(make-codes (map Clambda code*) (Expr body))]
[else (error who "invalid program ~s" x)]))
;;;
(Program x))
(define (eliminate-fix x)
;;;
(define who 'eliminate-fix)
;;;
(define (make-closure x)
(record-case x
[(closure code free*)
(cond
[(null? free*) x]
[else
(make-prim 'make-closure
(list code (make-constant (length free*))))])]))
;;;
(define (closure-sets var x)
(record-case x
[(closure code free*)
(let f ([i 0] [free* free*])
(cond
[(null? free*) (make-primcall 'void '())]
[else
(make-seq
(make-primcall 'closure-set!
(list var (make-constant i) (car free*)))
(f (fxadd1 i) (cdr free*)))]))]))
;;;
(define (do-fix lhs* rhs* body)
(make-bind lhs*
(map make-closure rhs*)
(let f ([lhs* lhs*] [rhs* rhs*])
(cond
[(null? lhs*) body]
[else
(make-seq
(closure-sets (car lhs*) (car rhs*))
(f (cdr lhs*) (cdr rhs*)))]))))
;;;
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* (Expr body))]
[(conditional e0 e1 e2)
(make-conditional (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(closure)
(let ([t (unique-var 'tmp)])
(Expr (make-fix (list t) (list x) t)))]
[(primcall op arg*)
(make-appcall (make-primref op) (map Expr arg*))]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
(make-funcall (Expr rator) (map Expr arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(appcall rator arg*)
(error who "appcall not supported yet")
(make-appcall (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr ~s" x)]))
;;;
(define (ClambdaCase x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]
[else (error who "invalid clambda-case ~s" x)]))
;;;
(define (Clambda x)
(record-case x
[(clambda label case* free*)
(make-clambda label (map ClambdaCase case*) free*)]
[else (error who "invalid clambda ~s" x)]))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(make-codes (map Clambda code*) (Expr body))]
[else (error who "invalid program ~s" x)]))
;;;
(Program x))
(define (specify-representation x)
(define who 'specify-representation)
;;;
(define nop (make-primcall 'nop '()))
;;;
(define (constant-rep x)
(let ([c (constant-value x)])
(cond
[(fixnum? c) (* c fixnum-scale)]
[(boolean? c) (if c bool-t bool-f)]
[(void? c) void-object]
[(bwp? c) bwp-object]
[(char? c) (fxlogor (fxsll (char->integer c) char-shift)
char-tag)]
[(null? c) nil]
[else x])))
;;;
(define (Effect x)
(record-case x
[(constant c) nop]
[(var) nop]
[(primref) nop]
[(closure code free*) nop]
[(bind lhs* rhs* body)
(make-bind lhs* (map Value rhs*) (Effect body))]
[(conditional e0 e1 e2)
(make-conditional (Pred e0) (Effect e1) (Effect e2))]
[(seq e0 e1)
(make-seq (Effect e0) (Effect e1))]
[(primcall op arg*)
(error who "effect prim ~a not supported" op)]
[(forcall op arg*)
(error who "effect forcall not supported" op)]
[(funcall rator arg*)
(make-funcall (Value rator) (map Value arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Value rator) (map Value arg*))]
[(appcall rator arg*)
(error who "appcall not supported yet")]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Effect))]
[else (error who "invalid pred expr ~s" x)]))
;;;
(define (Pred x)
(record-case x
[(constant c) (if c #t #f)]
[(var) (mkprm '!= (list x bool-f))]
[(primref) #t]
[(closure code free*) #t]
[(bind lhs* rhs* body)
(make-bind lhs* (map Value rhs*) (Pred body))]
[(conditional e0 e1 e2)
(make-conditional (Pred e0) (Pred e1) (Pred e2))]
[(seq e0 e1)
(make-seq (Effect e0) (Pred e1))]
[(primcall op arg*)
(error who "pred prim ~a not supported" op)]
[(forcall op arg*)
(error who "pred forcall not supported" op)]
[(funcall rator arg*)
(mkprm '!=
(list (make-funcall (Value rator) (map Value arg*))
bool-f))]
[(jmpcall label rator arg*)
(mkprm '!=
(list (make-jmpcall label (Value rator) (map Value arg*))
bool-f))]
[(appcall rator arg*)
(error who "appcall not supported yet")]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Pred))]
[else (error who "invalid pred expr ~s" x)]))
;;;
(define (Value x)
(record-case x
[(constant) (constant-rep x)]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Value rhs*) (Value body))]
[(conditional e0 e1 e2)
(make-conditional (Pred e0) (Value e1) (Value e2))]
[(seq e0 e1)
(make-seq (Effect e0) (Value e1))]
[(primcall op arg*)
(error who "value prim ~a not supported" op)]
[(forcall op arg*)
(error who "value forcall not supported" op)]
[(funcall rator arg*)
(make-funcall (Value rator) (map Value arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Value rator) (map Value arg*))]
[(appcall rator arg*)
(error who "appcall not supported yet")]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Value))]
[else (error who "invalid value expr ~s" x)]))
;;;
(define (ClambdaCase x k)
(record-case x
[(clambda-case info body)
(make-clambda-case info (k body))]
[else (error who "invalid clambda-case ~s" x)]))
;;;
(define (Clambda x k)
(record-case x
[(clambda label case* free*)
(make-clambda label
(map (lambda (x) (ClambdaCase x k)) case*)
free*)]
[else (error who "invalid clambda ~s" x)]))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(make-codes
(map (lambda (x) (Clambda x Value)) code*)
(Value body))]
[else (error who "invalid program ~s" x)]))
;;;
(Program x))
(define (new-cogen x)
(verify-new-cogen-input x)
(let* ([x (remove-primcalls x)]
[x (eliminate-fix x)]
[x (specify-representation x)])
x))