conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
ikarus/src/libaltcogen.ss

2321 lines
75 KiB
Scheme
Raw Normal View History

* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(module (alt-cogen)
;;; 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))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(module (must-open-code? prim-context
library-primitive?)
(define core-prims
'([pair? p]
[vector? p]
[null? p]
[eof-object? p]
* nothing much
2007-02-13 02:05:58 -05:00
[eof-object v]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[procedure? p]
[symbol? p]
[boolean? p]
[string? p]
[char? p]
[fixnum? p]
[string? p]
[immediate? p]
[char? p]
[eq? p]
[not not]
[void v]
[cons v]
[$car v]
[$cdr v]
* nothing much
2007-02-13 02:05:58 -05:00
[$fx+ v]
[$fxadd1 v]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[$fxsll v]
[$fxsra v]
[$fxlogand v]
[$fxmodulo v]
[$fxzero? p]
[$fx> p]
[$fx>= p]
[$fx< p]
[$fx<= p]
[$fx= p]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
* nothing much
2007-02-13 02:05:58 -05:00
[$char<= p]
[$char= p]
[$char->fixnum v]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[$vector-ref v]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[$vector-set! e]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
* can now compile libtoplevel
2007-02-12 23:19:56 -05:00
[$set-symbol-value! e]
* nothing much
2007-02-13 02:05:58 -05:00
[$record v]
[$record/rtd? p]
[$record-ref v]
[$record-set! e]
[$record? p]
[$record-rtd v]
[$make-record v]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
;;; ports
[output-port? p]
[input-port? p]
[port? p]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[$cpref v]
[$cpset! e]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[$make-cp v]
[$closure-code v]
[$code-freevars v]
[primitive-set! e]
* can now compile libtoplevel
2007-02-12 23:19:56 -05:00
[primitive-ref v]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[$fp-at-base p]
[$current-frame v]
[$seal-frame-and-call tail]
[$frame->continuation v]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
))
(define library-prims
'(vector
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
list list*
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
not
car cdr
* nothing much
2007-02-13 02:05:58 -05:00
top-level-value
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
))
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(define (must-open-code? x)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(and (assq x core-prims) #t))
(define (library-primitive? x)
(memq x library-prims))
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(define (prim-context x)
(cond
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(assq x core-prims) => cadr]
[else (error 'prim-context "~s is not a core prim" x)])))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;; 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)]))
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (mkfuncall op arg*)
(record-case op
[(primref name)
(cond
[(must-open-code? name)
(make-primcall name arg*)]
[(library-primitive? name)
(make-funcall op arg*)]
[(open-codeable? name)
(error 'chaitin-compiler "primitive ~s is not supported"
name)]
[else (make-funcall op arg*)])]
[else (make-funcall op arg*)]))
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(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*)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(mkfuncall (make-primref op) (map Expr arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(mkfuncall (Expr rator) (map Expr arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(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 (Expr cpvar free*)
;;;
(define (Var x)
(let f ([free* free*] [i 0])
(cond
[(null? free*) x]
[(eq? x (car free*))
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(make-primcall '$cpref (list cpvar (make-constant i)))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (f (cdr free*) (fxadd1 i))])))
;;;
(define (make-closure x)
(record-case x
[(closure code free*)
(cond
[(null? free*) x]
[else
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(make-primcall '$make-cp
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(list code (make-constant (length free*))))])]))
;;;
(define (closure-sets var x ac)
(record-case x
[(closure code free*)
(let f ([i 0] [free* free*])
(cond
[(null? free*) ac]
[else
(make-seq
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(make-primcall '$cpset!
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(list var (make-constant i)
(Var (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
(closure-sets (car lhs*) (car rhs*)
(f (cdr lhs*) (cdr rhs*)))]))))
;;;
(define (Expr x)
(record-case x
[(constant) x]
[(var) (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*)
* passinf 2.2
2007-02-11 19:17:59 -05:00
(make-primcall op (map Expr arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(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)]))
Expr)
;;;
(define (ClambdaCase free*)
(lambda (x)
(record-case x
[(clambda-case info body)
(record-case info
[(case-info label args proper)
(let ([cp (unique-var 'cp)])
(make-clambda-case
(make-case-info label (cons cp args) proper)
((Expr cp free*) body)))])]
[else (error who "invalid clambda-case ~s" x)])))
;;;
(define (Clambda x)
(record-case x
[(clambda label case* free*)
(make-clambda label (map (ClambdaCase free*) case*)
free*)]
[else (error who "invalid clambda ~s" x)]))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(make-codes (map Clambda code*) ((Expr #f '()) body))]
[else (error who "invalid program ~s" x)]))
;;;
(Program x))
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(define (normalize-context x)
(define who 'normalize-context)
;;;
(define nop (make-primcall 'nop '()))
;;;
(define (Predicafy x)
(make-primcall 'neq?
(list (V x) (make-constant #f))))
(define (Unpred x)
(make-conditional (P x)
(make-constant #t)
(make-constant #f)))
(define (mkif e0 e1 e2)
(record-case e0
[(constant c) (if c e1 e2)]
[(seq p0 p1)
(make-seq p0 (mkif p1 e1 e2))]
[else
(make-conditional e0 e1 e2)]))
(define (mkbind lhs* rhs* body)
(if (null? lhs*)
body
(make-bind lhs* rhs* body)))
(define (mkseq e0 e1)
(if (eq? e0 nop)
e1
(make-seq e0 e1)))
;;;
(define (P x)
(record-case x
[(constant v) (make-constant (not (not v)))]
[(primref) (make-constant #t)]
[(closure) (make-constant #t)]
[(code-loc) (make-constant #t)]
[(seq e0 e1)
(mkseq (E e0) (P e1))]
[(conditional e0 e1 e2)
(mkif (P e0) (P e1) (P e2))]
[(bind lhs* rhs* body)
(mkbind lhs* (map V rhs*) (P body))]
[(var) (Predicafy x)]
[(funcall) (Predicafy x)]
[(jmpcall) (Predicafy x)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall) (Predicafy x)]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(primcall op rands)
(case (prim-context op)
[(v) (Predicafy x)]
[(p) (make-primcall op (map V rands))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(e) (make-seq (E x) (make-constant #t))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(not)
(make-conditional
(P (car rands))
(make-constant #f)
(make-constant #t))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[else (error who "invalid context for ~s" op)])]
[else (error who "invalid pred ~s" x)]))
;;;
(define (E x)
(record-case x
[(constant) nop]
[(primref) nop]
[(var) nop]
[(closure) nop]
[(code-loc) nop]
[(seq e0 e1)
(mkseq (E e0) (E e1))]
[(bind lhs* rhs* body)
(mkbind lhs* (map V rhs*) (E body))]
[(conditional e0 e1 e2)
(let ([e1 (E e1)] [e2 (E e2)])
(cond
[(and (eq? e1 nop) (eq? e2 nop))
(E e0)]
[else
(mkif (P e0) e1 e2)]))]
[(funcall rator rand*)
(make-funcall (V rator) (map V rand*))]
[(jmpcall label rator rand*)
(make-jmpcall label (V rator) (map V rand*))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall op rands) (make-forcall op (map V rands))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(primcall op rands)
(case (prim-context op)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(p v not)
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(let f ([rands rands])
(cond
[(null? rands) nop]
[else
(mkseq (f (cdr rands)) (E (car rands)))]))]
[(e) (make-primcall op (map V rands))]
[else (error who "invalid context for ~s" op)])]
[else (error who "invalid effect ~s" x)]))
;;;
(define (V x)
(record-case x
[(constant) x]
[(primref) x]
[(var) x]
[(closure) x]
[(code-loc) x]
[(seq e0 e1)
(mkseq (E e0) (V e1))]
[(conditional e0 e1 e2)
(mkif (P e0) (V e1) (V e2))]
[(bind lhs* rhs* body)
(mkbind lhs* (map V rhs*) (V body))]
[(funcall rator rand*)
(make-funcall (V rator) (map V rand*))]
[(jmpcall label rator rand*)
(make-jmpcall label (V rator) (map V rand*))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall op rands) (make-forcall op (map V rands))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(primcall op rands)
(case (prim-context op)
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[(v tail) (make-primcall op (map V rands))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(p) (Unpred x)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(e) (make-seq (E x) (make-constant (void)))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(not)
(make-conditional
(P (car rands))
(make-constant #f)
(make-constant #t))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[else (error who "invalid context for ~s" op)])]
[else (error who "invalid value ~s" x)]))
;;;
(define (ClambdaCase x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (V 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*)
(V body))]
[else (error who "invalid program ~s" x)]))
;;;
(Program x))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(define-syntax seq*
(syntax-rules ()
[(_ e) e]
[(_ e* ... e)
(make-seq (seq* e* ...) e)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (specify-representation x)
(define who 'specify-representation)
;;;
(define fixnum-scale 4)
* nothing much
2007-02-13 02:05:58 -05:00
(define fixnum-shift 2)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define fixnum-tag 0)
(define fixnum-mask 3)
(define pcb-dirty-vector-offset 28)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define nop (make-primcall 'nop '()))
;;;
(define (constant-rep x)
(let ([c (constant-value x)])
(cond
[(fixnum? c) (make-constant (* c fixnum-scale))]
[(boolean? c) (make-constant (if c bool-t bool-f))]
[(eq? c (void)) (make-constant void-object)]
[(bwp-object? c) (make-constant bwp-object)]
[(char? c) (make-constant
(fxlogor char-tag
(fxsll (char->integer c) char-shift)))]
[(null? c) (make-constant nil)]
[else (make-constant (make-object c))])))
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (K x) (make-constant x))
(define (prm op . rands) (make-primcall op rands))
(define-syntax tbind
(lambda (x)
(syntax-case x ()
[(_ ([lhs* rhs*] ...) b b* ...)
#'(let ([lhs* (unique-var 'lhs*)] ...)
(make-bind (list lhs* ...)
(list rhs* ...)
b b* ...))])))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Effect x)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (mem-assign v x i)
(tbind ([q v])
(tbind ([t (prm 'int+ x (K i))])
(make-seq
(prm 'mset! t (K 0) q)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(prm 'mset!
(prm 'int+
(prm 'mref pcr (K 28))
(prm 'sll (prm 'sra t (K pageshift)) (K wordshift)))
(K 0)
(K dirty-word))))))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(record-case x
[(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*)
(case op
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(nop) nop]
[($cpset!)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(let ([x (Value (car arg*))]
[i (cadr arg*)]
[v (Value (caddr arg*))])
(record-case i
[(constant i)
(unless (fixnum? i) (err x))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(prm 'mset! x
(K (+ (* i wordsize)
(- disp-closure-data closure-tag)))
v)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (err x)]))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(primitive-set!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-system-value symbol-tag)))]
* can now compile libtoplevel
2007-02-12 23:19:56 -05:00
[($set-symbol-value!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-value symbol-tag)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($vector-set! $record-set!)
* passinf 2.2
2007-02-11 19:17:59 -05:00
(let ([x (Value (car arg*))]
[i (cadr arg*)]
[v (Value (caddr arg*))])
(record-case i
[(constant i)
(unless (fixnum? i) (err x))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(mem-assign v x
(+ (* i wordsize)
(- disp-vector-data vector-tag)))]
* passinf 2.2
2007-02-11 19:17:59 -05:00
[else
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(mem-assign v
(prm 'int+ x (Value i))
(- disp-vector-data vector-tag))]))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "invalid effect prim ~s" op)])]
[(forcall op arg*)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(make-forcall op (map Value arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(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))]
* nothing much
2007-02-13 02:05:58 -05:00
[else (error who "invalid effect expr ~s" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (tag-test x mask tag)
(if mask
(make-primcall '=
(list (make-primcall 'logand
(list x (make-constant mask)))
(make-constant tag)))
(make-primcall '=
(list x (make-constant tag)))))
(define (sec-tag-test x pmask ptag smask stag)
(let ([t (unique-var 'tmp)])
(make-bind (list t) (list x)
(make-conditional
(tag-test t pmask ptag)
(tag-test (prm 'mref t (K (- ptag))) smask stag)
(make-constant #f)))))
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Pred x)
(record-case x
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(constant) x]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(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*)
tests 2.4 pass
2007-02-11 21:18:12 -05:00
(case op
[(eq?) (make-primcall '= (map Value arg*))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(null?) (prm '= (Value (car arg*)) (K nil))]
[(eof-object?) (prm '= (Value (car arg*)) (K eof))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(neq?) (make-primcall '!= (map Value arg*))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[($fxzero?) (prm '= (Value (car arg*)) (K 0))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(pair?)
(tag-test (Value (car arg*)) pair-mask pair-tag)]
[(procedure?)
(tag-test (Value (car arg*)) closure-mask closure-tag)]
[(symbol?)
(tag-test (Value (car arg*)) symbol-mask symbol-tag)]
[(string?)
(tag-test (Value (car arg*)) string-mask string-tag)]
[(char?)
(tag-test (Value (car arg*)) char-mask char-tag)]
[(boolean?)
(tag-test (Value (car arg*)) bool-mask bool-tag)]
[(fixnum?)
(tag-test (Value (car arg*)) fixnum-mask fixnum-tag)]
[(vector?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag fixnum-mask fixnum-tag)]
* nothing much
2007-02-13 02:05:58 -05:00
[($record?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag vector-mask vector-tag)]
[(input-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f input-port-tag)]
[(output-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f output-port-tag)]
[(port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag port-mask port-tag)]
[($record/rtd?)
(tbind ([t (Value (car arg*))])
(make-conditional
(tag-test t vector-mask vector-tag)
(prm '=
(prm 'mref t (K (- vector-tag)))
(Value (cadr arg*)))
(make-constant #f)))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(output-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f output-port-tag)]
[(immediate?)
(tbind ([t (Value (car arg*))])
(make-conditional
(tag-test t fixnum-mask fixnum-tag)
(make-constant #t)
(tag-test t 7 7)))]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[($fp-at-base)
(prm '=
(prm 'int+
(prm 'mref pcr (K 12)) ;;; PCB FRAME-BASE
(K (- wordsize)))
fpr)]
* nothing much
2007-02-13 02:05:58 -05:00
[($fx= $char=)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm '= (Value (car arg*)) (Value (cadr arg*)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($fx< $char<)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm '< (Value (car arg*)) (Value (cadr arg*)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($fx> $char>)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm '> (Value (car arg*)) (Value (cadr arg*)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($fx<= $char<=)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm '<= (Value (car arg*)) (Value (cadr arg*)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($fx>= $char>=)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm '>= (Value (car arg*)) (Value (cadr arg*)))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[else (error who "pred prim ~a not supported" op)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Pred))]
[else (error who "invalid pred expr ~s" x)]))
;;;
(define (err x)
(error who "invalid form ~s" (unparse x)))
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
;;; value
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Value x)
(record-case x
[(constant) (constant-rep x)]
[(var) x]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primref name)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(prm 'mref
(K (make-object name))
(K (- disp-symbol-system-value symbol-tag)))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(code-loc) (make-constant x)]
[(closure) (make-constant 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*)
(case op
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(void) (K void-object)]
* nothing much
2007-02-13 02:05:58 -05:00
[(eof-object) (K eof)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[($car)
(prm 'mref (Value (car arg*)) (K (- disp-car pair-tag)))]
[($cdr)
(prm 'mref (Value (car arg*)) (K (- disp-cdr pair-tag)))]
* can now compile libtoplevel
2007-02-12 23:19:56 -05:00
[(primitive-ref)
(prm 'mref (Value (car arg*))
(K (- disp-symbol-system-value symbol-tag)))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[($make-cp)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(let ([label (car arg*)] [len (cadr arg*)])
(record-case len
[(constant i)
(unless (fixnum? i) (err x))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(tbind ([t (prm 'alloc
(K (align (+ disp-closure-data
(* i wordsize))))
(K closure-tag))])
(seq*
(prm 'mset! t
(K (- disp-closure-code closure-tag))
(Value label))
t))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (err x)]))]
* nothing much
2007-02-13 02:05:58 -05:00
[($record)
(let ([rtd (car arg*)] [v* (map Value (cdr arg*))])
(unless (constant? rtd)
(error who "invalid rtd ~s for $record" rtd))
(let ([t* (map (lambda (x) (unique-var 'v)) v*)])
(make-bind t* v*
(tbind ([t (prm 'alloc
(K (+ disp-record-data
(* (length v*) wordsize)))
(K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
(Value rtd))
(let f ([t* t*] [i (- disp-record-data vector-tag)])
(cond
[(null? t*) t]
[else
(make-seq
(prm 'mset! t (K i) (car t*))
(f (cdr t*) (+ i wordsize)))])))))))]
[($make-record)
(let ([rtd (car arg*)] [len (cadr arg*)])
(tbind ([rtd rtd])
(record-case len
[(constant i)
(unless (fixnum? i)
(error who "invalid make-rec ~s" len))
(tbind ([t (prm 'alloc
(K (align (+ (* i wordsize)
disp-record-data)))
(K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
rtd)
t))]
[else
(tbind ([len
(prm 'sll
(prm 'sra
(prm 'int+ (Value len)
(K (sub1
object-alignment)))
(K align-shift))
(K align-shift))])
(tbind ([t (prm 'alloc len (K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
rtd)
t)))])))]
[($record-rtd)
(prm 'mref (Value (car arg*))
(K (- disp-record-rtd vector-tag)))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(cons)
(tbind ([a (Value (car arg*))]
[d (Value (cadr arg*))])
(tbind ([t (prm 'alloc (K pair-size) (K pair-tag))])
(seq*
(prm 'mset! t (K (- disp-car pair-tag)) a)
(prm 'mset! t (K (- disp-cdr pair-tag)) d)
t)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($fxadd1)
(prm 'int+ (Value (car arg*)) (K (* 1 fixnum-scale)))]
[($fxsub1)
(prm 'int+ (Value (car arg*)) (K (* -1 fixnum-scale)))]
[($fx+)
(prm 'int+ (Value (car arg*)) (Value (cadr arg*)))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[($fxmodulo)
(tbind ([a (Value (car arg*))]
[b (Value (cadr arg*))])
(tbind ([c (prm 'logand b
(prm 'sra
(prm 'logxor b a)
(K (sub1 (* 8 wordsize)))))])
(prm 'int+ c (prm 'div a b))))]
[($fxsll)
(let ([a (car arg*)] [c (cadr arg*)])
(record-case c
[(constant i)
(if (fixnum? i)
(prm 'sll (Value a) (K i))
(error who "invalid arg to fxsll ~s" i))]
[else (error who "nonconst arg to fxsll ~s" c)]))]
[($fxsra)
(let ([a (car arg*)] [c (cadr arg*)])
(record-case c
[(constant i)
(if (fixnum? i)
(prm 'sra (Value a) (K i))
(error who "invalid arg to fxsra ~s" i))]
[else (error who "nonconst arg to fxsra ~s" c)]))]
[($fxlogand)
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
* nothing much
2007-02-13 02:05:58 -05:00
[($char->fixnum)
(prm 'sra
(Value (car arg*))
(K (- char-shift fixnum-shift)))]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[($current-frame) ;; PCB NEXT-CONTINUATION
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm 'mref pcr (K 20))]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[($seal-frame-and-call)
(tbind ([proc (Value (car arg*))])
(tbind ([k (prm 'alloc
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(K continuation-size)
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(K vector-tag))])
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(tbind ([base (prm 'int+ ;;; PCB BASE
(prm 'mref pcr (K 12))
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(K (- wordsize)))])
(tbind ([underflow-handler
(prm 'mref base (K 0))])
(seq*
(prm 'mset! k
(K (- vector-tag))
(K continuation-tag))
(prm 'mset! k
(K (- disp-continuation-top vector-tag))
fpr)
(prm 'mset! k
(K (- disp-continuation-next vector-tag))
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm 'mref pcr (K 20))) ;;; PCB NEXT CONT
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(prm 'mset! k
(K (- disp-continuation-size vector-tag))
(prm 'int- base fpr))
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(prm 'mset! pcr (K 20) k)
(prm 'mset! pcr (K 12) fpr)
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(make-primcall '$call-with-underflow-handler
(list underflow-handler proc k)))))))]
[($frame->continuation)
(tbind ([arg (Value (car arg*))])
(tbind ([t (prm 'alloc
(K (align (+ disp-closure-data wordsize)))
(K closure-tag))])
(seq*
(prm 'mset! t
(K (- disp-closure-code closure-tag))
(make-constant
(make-code-loc SL_continuation_code)))
(prm 'mset! t
(K (- disp-closure-data closure-tag))
arg)
t)))]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[($cpref)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(let ([a0 (car arg*)] [a1 (cadr arg*)])
(record-case a1
[(constant i)
(unless (fixnum? i) (err x))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(prm 'mref (Value a0)
(K (+ (- disp-closure-data closure-tag)
(* i wordsize))))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (err x)]))]
* nothing much
2007-02-13 02:05:58 -05:00
[($vector-ref $record-ref)
* passinf 2.2
2007-02-11 19:17:59 -05:00
(let ([a0 (car arg*)] [a1 (cadr arg*)])
(record-case a1
[(constant i)
(unless (fixnum? i) (err x))
(make-primcall 'mref
(list (Value a0)
(make-constant
(+ (- disp-vector-data vector-tag)
(* i wordsize)))))]
[else
(make-primcall 'mref
(list (make-primcall 'int+
(list (Value a0)
(Value a1)))
(make-constant
(- disp-vector-data vector-tag))))]))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[($closure-code)
(prm 'int+
(prm 'mref
(Value (car arg*))
(K (- disp-closure-code closure-tag)))
(K (- vector-tag disp-code-data)))]
[($code-freevars)
(prm 'mref
(Value (car arg*))
(K (- disp-code-freevars vector-tag)))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "value prim ~a not supported" (unparse x))])]
[(forcall op arg*)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(make-forcall op (map Value arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(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)]))
;;;
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
;(print-code x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(Program x))
(define parameter-registers '(%edi))
(define return-value-register '%eax)
(define cp-register '%edi)
(define all-registers '(%eax %edi %ebx %edx))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define argc-register '%eax)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (impose-calling-convention/evaluation-order x)
(define who 'impose-calling-convention/evaluation-order)
;;;
;;;
(define (S* x* k)
(cond
[(null? x*) (k '())]
[else
(S (car x*)
(lambda (a)
(S* (cdr x*)
(lambda (d)
(k (cons a d))))))]))
;;;
(define (S x k)
* passinf 2.2
2007-02-11 19:17:59 -05:00
(record-case x
[(bind lhs* rhs* body)
(do-bind lhs* rhs* (S body k))]
[(seq e0 e1)
(make-seq (E e0) (S e1 k))]
[else
(cond
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(or (constant? x) (var? x) (symbol? x)) (k x)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(or (funcall? x) (primcall? x) (jmpcall? x)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(forcall? x)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(conditional? x))
* passinf 2.2
2007-02-11 19:17:59 -05:00
(let ([t (unique-var 'tmp)])
(do-bind (list t) (list x)
(k t)))]
[else (error who "invalid S ~s" x)])]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (do-bind lhs* rhs* body)
(cond
[(null? lhs*) body]
[else
(set! locals (cons (car lhs*) locals))
(make-seq
(V (car lhs*) (car rhs*))
(do-bind (cdr lhs*) (cdr rhs*) body))]))
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (nontail-locations args)
(let f ([regs parameter-registers] [args args])
(cond
[(null? args) (values '() '() '())]
[(null? regs) (values '() '() args)]
[else
(let-values ([(r* rl* f*) (f (cdr regs) (cdr args))])
(values (cons (car regs) r*)
(cons (car args) rl*)
f*))])))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (do-bind-frmt* nf* v* ac)
(cond
[(null? nf*) ac]
[else
(let ([t (unique-var 't)])
(do-bind (list t) (list (car v*))
(make-seq
(make-set (car nf*) t)
(do-bind-frmt* (cdr nf*) (cdr v*) ac))))]))
;;;
* passing 2.1
2007-02-11 18:52:10 -05:00
(define (handle-nontail-call rator rands value-dest call-targ)
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
(let-values ([(reg-locs reg-args frm-args)
(nontail-locations (cons rator rands))])
(let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[frmt* (map (lambda (x) (make-nfvar 'unset-conflicts #f)) frm-args)])
* passing 2.1
2007-02-11 18:52:10 -05:00
(let* ([call
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(make-ntcall call-targ value-dest
(cons argc-register (append reg-locs frmt*))
#f #f)]
* passing 2.1
2007-02-11 18:52:10 -05:00
[body
(make-nframe frmt* #f
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(do-bind-frmt* frmt* frm-args
* passing 2.1
2007-02-11 18:52:10 -05:00
(do-bind regt* reg-args
(assign* reg-locs regt*
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
call)))))])
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(if value-dest
* passing 2.1
2007-02-11 18:52:10 -05:00
(make-seq body (make-set value-dest return-value-register))
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
body)))))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; impose value
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (V d x)
(record-case x
[(constant) (make-set d x)]
[(var) (make-set d x)]
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (V d e))]
[(seq e0 e1)
(make-seq (E e0) (V d e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (V d e1) (V d e2))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(case op
[(alloc)
(S (car rands)
(lambda (size)
(S (cadr rands)
(lambda (tag)
(make-seq
(make-seq
(make-set d apr)
(make-asm-instr 'logor d tag))
(make-asm-instr 'int+ apr size))))))]
[(mref)
(S* rands
(lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(logand logxor int+ int-)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-seq
(V d (car rands))
(S (cadr rands)
(lambda (s)
(make-asm-instr op d s))))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(div)
(S* rands
(lambda (rands)
(seq*
(make-set eax (car rands))
(make-asm-instr 'cltd edx eax)
(make-asm-instr 'idiv edx (cadr rands))
(make-set d edx))))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(sll sra)
(let ([a (car rands)] [b (cadr rands)])
(cond
[(constant? b)
(make-seq
(V d a)
(make-asm-instr op d b))]
[else (error who "invalid shift ~s" x)]))]
[else (error who "invalid value op ~s" op)])]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(funcall rator rands)
* passing 2.1
2007-02-11 18:52:10 -05:00
(handle-nontail-call rator rands d #f)]
[(jmpcall label rator rands)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(handle-nontail-call rator rands d label)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall op rands)
(handle-nontail-call
(make-constant (make-foreign-label op))
rands d op)]
[else
(if (symbol? x)
(make-set d x)
(error who "invalid value ~s" x))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (assign* lhs* rhs* ac)
(cond
[(null? lhs*) ac]
[else
(make-seq
(make-set (car lhs*) (car rhs*))
(assign* (cdr lhs*) (cdr rhs*) ac))]))
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (VT x)
(make-seq
(V return-value-register x)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(make-primcall 'return (list return-value-register))))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; impose effect
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (E x)
(record-case x
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (E e))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(case op
[(mset!)
(S* rands
(lambda (s*)
(make-asm-instr 'mset
(make-disp (car s*) (cadr s*))
(caddr s*))))]
[(nop) x]
[else (error 'impose-effect "invalid instr ~s" x)])]
; (S* rands
; (lambda (rands)
; (make-primcall op rands)))]
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
[(funcall rator rands)
* passing 2.1
2007-02-11 18:52:10 -05:00
(handle-nontail-call rator rands #f #f)]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(jmpcall label rator rands)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(handle-nontail-call rator rands #f label)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall op rands)
(handle-nontail-call
(make-constant (make-foreign-label op))
rands #f op)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[else (error who "invalid effect ~s" x)]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; impose pred
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x)
(record-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1) (make-seq (E e0) (P e1))]
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (P e))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(primcall op rands)
(S* rands
(lambda (rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-asm-instr op (car rands) (cadr rands))))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[else (error who "invalid pred ~s" x)]))
;;;
* passing 2.1
2007-02-11 18:52:10 -05:00
(define (handle-tail-call target rator rands)
(let ([cpt (unique-var 'rator)]
[rt* (map (lambda (x) (unique-var 't)) rands)])
(do-bind rt* rands
(do-bind (list cpt) (list rator)
(let ([args (cons cpt rt*)]
[locs (formals-locations (cons cpt rt*))])
(assign* (reverse locs)
(reverse args)
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(cond
[target
(make-primcall 'direct-jump (cons target locs))]
[else
(make-primcall 'indirect-jump locs)]))))))))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Tail x)
(record-case x
[(constant) (VT x)]
[(var) (VT x)]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[(primcall op rands)
(case op
[($call-with-underflow-handler)
(let ([handler (car rands)]
[proc (cadr rands)]
[k (caddr rands)])
(seq*
(make-set (make-fvar 1) handler)
(make-set (make-fvar 2) k)
(make-set cpr proc)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(make-set argc-register (make-constant (argc-convention 1)))
(make-asm-instr 'int- fpr (make-constant wordsize))
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(make-primcall 'indirect-jump
(list cpr (make-fvar 1) (make-fvar 2)))))]
[else (VT x)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (Tail e))]
[(seq e0 e1)
(make-seq (E e0) (Tail e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (Tail e1) (Tail e2))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(funcall rator rands)
* passing 2.1
2007-02-11 18:52:10 -05:00
(handle-tail-call #f rator rands)]
[(jmpcall label rator rands)
(handle-tail-call (make-code-loc label) rator rands)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall) (VT x)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "invalid tail ~s" x)]))
;;;
(define (formals-locations args)
(let f ([regs parameter-registers] [args args])
(cond
[(null? args) '()]
[(null? regs)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let f ([i 1] [args args])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cond
[(null? args) '()]
[else
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(cons (mkfvar i)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(f (fxadd1 i) (cdr args)))]))]
[else
(cons (car regs) (f (cdr regs) (cdr args)))])))
;;;
(define locals '())
;;;
(define (ClambdaCase x)
(record-case x
[(clambda-case info body)
(record-case info
[(case-info label args proper)
(set! locals args)
(let* ([locs (formals-locations args)]
[body (let f ([args args] [locs locs])
(cond
[(null? args) (Tail body)]
[else
(make-seq
(make-set (car args) (car locs))
(f (cdr args) (cdr locs)))]))])
(make-clambda-case
(make-case-info label locs proper)
(make-locals locals body)))])]))
;;;
(define (Clambda x)
(record-case x
[(clambda label case* free*)
(make-clambda label (map ClambdaCase case*) free*)]))
;;;
(define (Main x)
(set! locals '())
(let ([x (Tail x)])
(make-locals locals x)))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(make-codes (map Clambda code*) (Main body))]))
;;;
(Program x))
(module ListyGraphs
(empty-graph add-edge! empty-graph? print-graph node-neighbors
delete-node!)
;;;
(define-record graph (ls))
;;;
(define (empty-graph) (make-graph '()))
;;;
(define (empty-graph? g)
(andmap (lambda (x) (null? (cdr x))) (graph-ls g)))
;;;
(define (add-edge! g x y)
(let ([ls (graph-ls g)])
(cond
[(assq x ls) =>
(lambda (p0)
(unless (memq y (cdr p0))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(set-cdr! p0 (cons y (cdr p0)))
(cond
[(assq y ls) =>
(lambda (p1)
(set-cdr! p1 (cons x (cdr p1))))]
[else
(set-graph-ls! g
(cons (list y x) ls))])))]
[(assq y ls) =>
(lambda (p1)
(set-cdr! p1 (cons x (cdr p1)))
(set-graph-ls! g (cons (list x y) ls)))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else
(set-graph-ls! g
(list* (list x y)
(list y x)
ls))])))
(define (print-graph g)
(printf "G={\n")
(parameterize ([print-gensym 'pretty])
(for-each (lambda (x)
(let ([lhs (car x)] [rhs* (cdr x)])
(printf " ~s => ~s\n"
(unparse lhs)
(map unparse rhs*))))
(graph-ls g)))
(printf "}\n"))
(define (node-neighbors x g)
(cond
[(assq x (graph-ls g)) => cdr]
[else '()]))
(define (delete-node! x g)
(let ([ls (graph-ls g)])
(cond
[(assq x ls) =>
(lambda (p)
(for-each (lambda (y)
(let ([p (assq y ls)])
(set-cdr! p (set-rem x (cdr p)))))
(cdr p))
(set-cdr! p '()))]
[else (void)])))
;;;
#|ListyGraphs|#)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(begin
(define (set-add x s)
(cond
[(memq x s) s]
[else (cons x s)]))
(define (set-rem x s)
(cond
[(null? s) '()]
[(eq? x (car s)) (cdr s)]
[else (cons (car s) (set-rem x (cdr s)))]))
(define (set-difference s1 s2)
(cond
[(null? s2) s1]
[else (set-difference (set-rem (car s2) s1) (cdr s2))]))
(define (set-union s1 s2)
(cond
[(null? s1) s2]
[(memq (car s1) s2) (set-union (cdr s1) s2)]
[else (cons (car s1) (set-union (cdr s1) s2))])))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(module (color-by-chaitin)
(import ListyGraphs)
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (build-graph x reg?)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define who 'build-graph)
(define g (empty-graph))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (R* ls)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cond
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(null? ls) '()]
[else (union (R (car ls)) (R* (cdr ls)))]))
(define (R x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(record-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(constant) '()]
[(var) (list x)]
[(disp s0 s1) (union (R s0) (R s1))]
[(nfvar) (list x)]
[(fvar) (if (reg? x) (list x) '())]
[(code-loc) '()]
[else
(cond
[(symbol? x) (if (reg? x) (list x) '())]
[else (error who "invalid R ~s" x)])]))
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
;;; build effect
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (E x s)
(record-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(set x v)
(let ([s (set-rem x s)])
(record-case x
[(nfvar c i)
(if (list? c)
(set-nfvar-conf! x
(set-union c s))
(set-nfvar-conf! x s))
(union (R v) s)]
[else
(for-each (lambda (y) (add-edge! g x y)) s)
(union (R v) s)]))]
[(asm-instr op d v)
(case op
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(logand logxor int+ int- logor sll sra)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([s (set-rem d s)])
(record-case d
[(nfvar c i)
(if (list? c)
(set-nfvar-conf! d
(set-union c s))
(set-nfvar-conf! d s))
(union (union (R v) (R d)) s)]
[else
(for-each (lambda (y) (add-edge! g d y)) s)
(union (union (R v) (R d)) s)]))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(cltd)
(let ([s (set-rem edx s)])
(when (register? edx)
(for-each (lambda (y)
(add-edge! g edx y))
s))
(union (R eax) s))]
[(idiv)
(let ([s (set-rem eax (set-rem edx s))])
(when (register? eax)
(for-each (lambda (y)
(add-edge! g eax y)
(add-edge! g edx y))
s))
(union (union (R eax) (R edx))
(union (R d) s)))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(mset)
(union (R v) (union (R d) s))]
[else (error who "invalid effect ~s" x)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (E e0 (E e1 s))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(let ([s1 (E e1 s)] [s2 (E e2 s)])
(P e0 s1 s2 (set-union s1 s2)))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(nframe vars live body)
(when (reg? return-value-register)
(for-each
(lambda (x)
(for-each (lambda (r)
(add-edge! g x r))
all-registers))
s))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([s (set-difference s all-registers)])
(set-nframe-live! x s)
(E body s))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall targ value args mask size)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(union (R* args) s)]
[(primcall op arg*)
(case op
[(nop) s]
[else (error who "invalid effect primcall ~s" op)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "invalid effect ~s" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x st sf su)
(record-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant c) (if c st sf)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1)
(E e0 (P e1 st sf su))]
[(conditional e0 e1 e2)
(let ([s1 (P e1 st sf su)] [s2 (P e2 st sf su)])
(P e0 s1 s2 (set-union s1 s2)))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op s0 s1)
(union (union (R s0) (R s1)) su)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[else (error who "invalid pred ~s" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (T x)
(record-case x
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(let ([s1 (T e1)] [s2 (T e2)])
(P e0 s1 s2 (set-union s1 s2)))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(R* rands)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (E e0 (T e1))]
[else (error who "invalid tail ~s" x)]))
(let ([s (T x)])
;(print-graph g)
g))
;;;
(define (color-graph sp* un* g)
(define (find-low-degree ls g)
(cond
[(null? ls) #f]
[(fx< (length (node-neighbors (car ls) g))
(length all-registers))
(car ls)]
[else (find-low-degree (cdr ls) g)]))
(define (find-color/maybe x confs env)
(let ([cr (map (lambda (x)
(cond
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(symbol? x) x]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(assq x env) => cdr]
[else #f]))
confs)])
(let ([r* (set-difference all-registers cr)])
(if (null? r*)
#f
(car r*)))))
(define (find-color x confs env)
(or (find-color/maybe x confs env)
(error 'find-color "cannot find color for ~s" x)))
(cond
[(and (null? sp*) (null? un*)) (values '() '() '())]
[(find-low-degree un* g) =>
(lambda (un)
(let ([n* (node-neighbors un g)])
(delete-node! un g)
(let-values ([(spills sp* env)
(color-graph sp* (set-rem un un*) g)])
(let ([r (find-color un n* env)])
(values spills sp*
(cons (cons un r) env))))))]
[(find-low-degree sp* g) =>
(lambda (sp)
(let ([n* (node-neighbors sp g)])
(delete-node! sp g)
(let-values ([(spills sp* env)
(color-graph (set-rem sp sp*) un* g)])
(let ([r (find-color sp n* env)])
(values spills (cons sp sp*)
(cons (cons sp r) env))))))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(pair? sp*)
(let ([sp (car sp*)])
(let ([n* (node-neighbors sp g)])
(delete-node! sp g)
(let-values ([(spills sp* env)
(color-graph (set-rem sp sp*) un* g)])
(let ([r (find-color/maybe sp n* env)])
(if r
(values spills (cons sp sp*)
(cons (cons sp r) env))
(values (cons sp spills) sp* env))))))]
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
[else (error 'color-graph "whoaaa")]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
(define (substitute env x frm-graph)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define who 'substitute)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (max-live vars i)
(cond
[(null? vars) i]
[else (max-live (cdr vars)
(record-case (car vars)
[(fvar j) (max i j)]
[else i]))]))
(define (actual-frame-size vars i)
(define (conflicts? i ls)
(and (not (null? ls))
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
(or (let f ([x (car ls)])
(record-case x
[(fvar j) (eq? i j)]
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
[(var)
(cond
[(assq x env) => (lambda (x) (f (cdr x)))]
[else #f])]
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
[(nfvar conf loc) (f loc)]
[else #f]))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(conflicts? i (cdr ls)))))
(define (frame-size-ok? i vars)
(or (null? vars)
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
(and (not (conflicts? i (nfvar-conf (car vars))))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(frame-size-ok? (fxadd1 i) (cdr vars)))))
(cond
[(frame-size-ok? i vars) i]
[else (actual-frame-size vars (fxadd1 i))]))
(define (assign-frame-vars! vars i)
(unless (null? vars)
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
(let ([v (car vars)]
[fv (mkfvar i)])
(set-nfvar-loc! v fv)
(for-each
(lambda (x)
(when (var? x)
(add-edge! frm-graph x fv)))
(nfvar-conf v)))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(assign-frame-vars! (cdr vars) (fxadd1 i))))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Var x)
(cond
[(assq x env) => cdr]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else x]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Rhs x)
(record-case x
[(var) (Var x)]
[(primcall op rand*)
(make-primcall op (map Rand rand*))]
[else x]))
(define (Rand x)
(record-case x
[(var) (Var x)]
[else x]))
(define (Lhs x)
(record-case x
[(var) (Var x)]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(nfvar confs loc)
(or loc (error who "LHS not set ~s" x))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else x]))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (NFE idx mask x)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(record-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(seq e0 e1) (make-seq (E e0) (NFE idx mask e1))]
[(ntcall target value args mask^ size)
(make-ntcall target value
(map (lambda (x)
(if (symbol? x)
x
(Lhs x)))
args)
mask idx)]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else (error who "invalid NF effect ~s" x)]))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (make-mask n live*)
(let ([v (make-vector (fxsra (fx+ n 7) 3) 0)])
(for-each
(lambda (x)
(record-case x
[(fvar idx)
(let ([q (fxsra idx 3)]
[r (fxlogand idx 7)])
(vector-set! v q
(fxlogor (vector-ref v q) (fxsll 1 r))))]
[else (void)]))
live*)
v))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (D x)
(record-case x
[(constant) x]
[(var) (Var x)]
[(fvar) x]
[else
(if (symbol? x) x (error who "invalid D ~s" x))]))
(define (R x)
(record-case x
[(constant) x]
[(var) (Var x)]
[(fvar) x]
[(nfvar c loc)
(or loc (error who "unset nfvar ~s in R" x))]
[(disp s0 s1) (make-disp (D s0) (D s1))]
[else
(if (symbol? x) x (error who "invalid R ~s" x))]))
;;; substitute effect
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (E x)
(record-case x
[(set lhs rhs)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([lhs (R lhs)] [rhs (R rhs)])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cond
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(or (eq? lhs rhs)
(and (fvar? lhs) (fvar? rhs)
(fixnum? (fvar-idx lhs))
(fixnum? (fvar-idx rhs))
(fx= (fvar-idx lhs) (fvar-idx rhs))))
(make-primcall 'nop '())]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (make-set lhs rhs)]))]
[(seq e0 e1) (make-seq (E e0) (E e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op x v)
(make-asm-instr op (R x) (R v))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-primcall op (map R rands))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(nframe vars live body)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([live-fv*
(map (lambda (x)
(record-case x
[(var)
(let ([l (Var x)])
(if (fvar? l)
l
(error who "unspilled live-after ~s"
x)))]
[(nfvar c loc)
(or loc (error who "unspilled live-after ~s" x))]
[else
(error who "invalid live-after ~s" x)]))
live)])
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(let ([i (actual-frame-size vars
(fx+ 2 (max-live live-fv* 0)))])
(assign-frame-vars! vars i)
(NFE (fxsub1 i) (make-mask i live-fv*) body)))]
[(ntcall) x]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "invalid effect ~s" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x)
(record-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant) x]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op x v)
(make-asm-instr op (R x) (R v))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))]
[else (error who "invalid pred ~s" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (T x)
(record-case x
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (make-seq (E e0) (T e1))]
[else (error who "invalid tail ~s" x)]))
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
;(print-code x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(T x))
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (do-spill sp* g)
(define (find/set-loc x)
(let ([ls (node-neighbors x g)])
(define (conflicts? i ls)
(and (pair? ls)
(or (record-case (car ls)
[(fvar j)
(and (fixnum? j) (fx= i j))]
[else #f])
(conflicts? i (cdr ls)))))
(let f ([i 1])
(cond
[(conflicts? i ls) (f (fxadd1 i))]
[else
(let ([fv (mkfvar i)])
(for-each (lambda (y) (add-edge! g y fv)) ls)
(delete-node! x g)
(cons x fv))]))))
(map find/set-loc sp*))
;;;
(define (add-unspillables un* x)
(define who 'add-unspillables)
(define (mku)
(let ([u (unique-var 'u)])
(set! un* (cons u un*))
u))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (S x k)
(cond
[(or (constant? x) (var? x) (symbol? x))
(k x)]
[else
(let ([u (mku)])
(make-seq (E (make-set u x)) (k u)))]))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (S* ls k)
(cond
[(null? ls) (k '())]
[else
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(S (car ls)
(lambda (a)
(S* (cdr ls)
(lambda (d)
(k (cons a d))))))]))
(define (mem? x)
(or (disp? x) (fvar? x)))
;;; unspillable effect
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (E x)
(record-case x
[(set lhs rhs)
(cond
[(or (constant? rhs) (var? rhs) (symbol? rhs)) x]
[(fvar? lhs)
(cond
[else
(let ([u (mku)])
(make-seq
(E (make-set u rhs))
(make-set lhs u)))])]
[(fvar? rhs) x]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(disp? rhs)
(S (disp-s0 rhs)
(lambda (s0)
(S (disp-s1 rhs)
(lambda (s1)
(make-set lhs (make-disp s0 s1))))))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else (error who "invalid set in ~s" x)])]
[(seq e0 e1) (make-seq (E e0) (E e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op a b)
(case op
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[(logor logand int+ int-)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(cond
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq
(E (make-set u b))
(E (make-asm-instr op a u))))]
[else x])]
[(sll sra)
(unless (constant? b) (error who "invalid shift ~s" b))
x]
[(mset)
(cond
[(mem? b)
(let ([u (mku)])
(make-seq
(E (make-set u b))
(E (make-asm-instr op a u))))]
[else
(let ([s1 (disp-s0 a)] [s2 (disp-s1 a)])
(cond
[(and (mem? s1) (mem? s2))
(let ([u (mku)])
(make-seq
(make-seq
(E (make-set u s1))
(E (make-asm-instr 'int+ u s2)))
(make-asm-instr 'mset
(make-disp u (make-constant 0))
b)))]
[(mem? s1)
(let ([u (mku)])
(make-seq
(E (make-set u s1))
(make-asm-instr 'mset (make-disp u s2) b)))]
[(mem? s2)
(let ([u (mku)])
(make-seq
(E (make-set u s2))
(make-asm-instr 'mset (make-disp u s1) b)))]
[else x]))])]
[else (error who "invalid effect ~s" op)])]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands)
(case op
[(nop) x]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(record-effect)
* passinf 2.2
2007-02-11 19:17:59 -05:00
(S* rands
(lambda (s*)
(make-primcall op s*)))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else (error who "invalid op in ~s" x)])]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall) x]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else (error who "invalid effect ~s" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x)
(record-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(primcall op rands)
(let ([a0 (car rands)] [a1 (cadr rands)])
(cond
[(and (fvar? a0) (fvar? a1))
(let ([u (mku)])
(make-seq
(make-set u a0)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(make-primcall op (list u a1))))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[else x]))]
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op a b)
(cond
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq
(E (make-set u b))
(make-asm-instr op a u)))]
[else x])]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[else (error who "invalid pred ~s" x)]))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (T x)
(record-case x
[(primcall op rands) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(seq e0 e1) (make-seq (E e0) (T e1))]
[else (error who "invalid tail ~s" x)]))
(let ([x (T x)])
(values un* x)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (color-program x)
(define who 'color-program)
(record-case x
[(locals sp* body)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let ([frame-g (build-graph body fvar?)])
(let loop ([sp* sp*] [un* '()] [body body])
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(printf "a")
(let ([g (build-graph body
(lambda (x)
(and (symbol? x)
(memq x all-registers))))])
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
; (printf "loop:\n")
; (print-code body)
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
;(print-graph g)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(printf "b")
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let-values ([(spills sp* env) (color-graph sp* un* g)])
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(printf "c")
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(cond
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
[(null? spills) (substitute env body frame-g)]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(printf "d")
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let* ([env (do-spill spills frame-g)]
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
[body (substitute env body frame-g)])
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(printf "e")
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let-values ([(un* body)
(add-unspillables un* body)])
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(printf "f")
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(loop sp* un* body)))])))))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (color-by-chaitin x)
;;;
(define (ClambdaCase x)
(record-case x
[(clambda-case info body)
(make-clambda-case info (color-program body))]))
;;;
(define (Clambda x)
(record-case x
[(clambda label case* free*)
(make-clambda label (map ClambdaCase case*) free*)]))
;;;
(define (Program x)
(record-case x
[(codes code* body)
(make-codes (map Clambda code*) (color-program body))]))
;;;
(Program x))
#|chaitin module|#)
(define (flatten-codes x)
(define who 'flatten-codes)
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (FVar i)
`(disp ,(* i (- wordsize)) ,fpr))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;;
(define (C x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(record-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(code-loc label) (label-address label)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(foreign-label L) `(foreign-label ,L)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(closure label free*)
(unless (null? free*) (error who "nonempty closure"))
`(obj ,x)]
[(object o)
`(obj ,o)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(if (integer? x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(error who "invalid constant C ~s" x))]))
(define (D x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(record-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(constant c) (C c)]
[else
(if (symbol? x) x (error who "invalid D ~s" x))]))
(define (R x)
(record-case x
[(constant c) (C c)]
[(fvar i) (FVar i)]
[(disp s0 s1)
(let ([s0 (D s0)] [s1 (D s1)])
`(disp ,s0 ,s1))]
[else
(if (symbol? x) x (error who "invalid R ~s" x))]))
;;; flatten effect
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (E x ac)
(record-case x
[(seq e0 e1) (E e0 (E e1 ac))]
[(set lhs rhs)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(cons `(movl ,(R rhs) ,(R lhs)) ac)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
* passing 2.1
2007-02-11 18:52:10 -05:00
(let ([lf (unique-label)] [le (unique-label)])
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(P e0 #f lf
(E e1
* passing 2.1
2007-02-11 18:52:10 -05:00
(list* `(jmp ,le) lf
(E e2 (cons le ac))))))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall target value args mask size)
(let ([LCALL (unique-label)])
(define (rp-label value)
(if value
(label-address SL_multiple_values_error_rp)
(label-address SL_multiple_values_ignore_rp)))
(cond
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(string? target) ;; foreign call
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(movl (foreign-label "ik_foreign_call") %ebx)
`(jmp ,LCALL)
`(byte-vector ,mask)
`(int ,(* size wordsize))
`(current-frame-offset)
(rp-label value)
'(byte 0)
'(byte 0)
'(byte 0)
LCALL
`(call %ebx)
;;ik_foreign_call adjusts fp back
ac)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[target ;;; known call
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(jmp ,LCALL)
`(byte-vector ,mask)
`(int ,(* size wordsize))
`(current-frame-offset)
(rp-label value)
LCALL
`(call (label ,target))
`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]
[else
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(jmp ,LCALL)
`(byte-vector ,mask)
`(int ,(* size wordsize))
`(current-frame-offset)
(rp-label value)
'(byte 0)
'(byte 0)
LCALL
`(call (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op d s)
(case op
[(logand) (cons `(andl ,(R s) ,(R d)) ac)]
[(int+) (cons `(addl ,(R s) ,(R d)) ac)]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[(int-) (cons `(subl ,(R s) ,(R d)) ac)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(logxor) (cons `(xorl ,(R s) ,(R d)) ac)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R s) ,(R d)) ac)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(idiv) (cons `(idivl ,(R s)) ac)]
[(cltd) (cons `(cltd) ac)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[else (error who "invalid instr ~s" x)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
(case op
[(nop) ac]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(record-effect)
(let ([a (car rands)])
(unless (symbol? a)
(error who "invalid arg to record-effect ~s" a))
(list* `(shrl ,pageshift ,a)
`(sall ,wordshift ,a)
`(addl ,(pcb-ref 'dirty-vector) ,a)
`(movl ,dirty-word (disp 0 ,a))
ac))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "invalid effect ~s" x)])]
[else (error who "invalid effect ~s" x)]))
;;;
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (unique-label)
(label (gensym)))
;;;
(define (P x lt lf ac)
(record-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant c)
(if c
(if lt (cons `(jmp ,lt) ac) ac)
(if lf (cons `(jmp ,lf) ac) ac))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1)
(E e0 (P e1 lt lf ac))]
[(conditional e0 e1 e2)
(cond
[(and lt lf)
(let ([l (unique-label)])
(P e0 #f l
(P e1 lt lf
(cons l (P e2 lt lf ac)))))]
[lt
(let ([lf (unique-label)] [l (unique-label)])
(P e0 #f l
(P e1 lt lf
(cons l (P e2 lt #f (cons lf ac))))))]
[lf
(let ([lt (unique-label)] [l (unique-label)])
(P e0 #f l
(P e1 lt lf
(cons l (P e2 #f lf (cons lt ac))))))]
[else
(let ([lf (unique-label)] [l (unique-label)])
(P e0 #f l
(P e1 #f #f
(cons `(jmp ,lf)
(cons l (P e2 #f #f (cons lf ac)))))))])]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op a0 a1)
(let ()
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (notop x)
(cond
[(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]))
=> cadr]
[else (error who "invalid op ~s" x)]))
(define (jmpname x)
(cond
[(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]))
=> cadr]
[else (error who "invalid jmpname ~s" x)]))
(define (revjmpname x)
(cond
[(assq x '([= je] [!= jne] [< jg] [<= jge] [> jl] [>= jle]))
=> cadr]
[else (error who "invalid jmpname ~s" x)]))
(define (cmp op a0 a1 lab ac)
(cond
[(or (symbol? a0) (constant? a1))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(list* `(cmpl ,(R a1) ,(R a0))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
`(,(jmpname op) ,lab)
ac)]
[(or (symbol? a1) (constant? a0))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(list* `(cmpl ,(R a0) ,(R a1))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
`(,(revjmpname op) ,lab)
ac)]
[else (error who "invalid ops ~s ~s" a0 a1)]))
(cond
[(and lt lf)
(cmp op a0 a1 lt
(cons `(jmp ,lf) ac))]
[lt
(cmp op a0 a1 lt ac)]
[lf
(cmp (notop op) a0 a1 lf ac)]
[else ac]))]
[else (error who "invalid pred ~s" x)]))
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (T x ac)
(record-case x
[(seq e0 e1) (E e0 (T e1 ac))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(let ([L (unique-label)])
(P e0 #f L (T e1 (cons L (T e2 ac)))))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
(case op
[(return) (cons '(ret) ac)]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(indirect-jump)
(cons `(jmp (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
ac)]
* passing 2.1
2007-02-11 18:52:10 -05:00
[(direct-jump)
(cons `(jmp (label ,(code-loc-label (car rands)))) ac)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (error who "invalid tail ~s" x)])]
[else (error who "invalid tail ~s" x)]))
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (handle-vararg fml-count ac)
(define CONTINUE_LABEL (unique-label))
(define DONE_LABEL (unique-label))
(define CONS_LABEL (unique-label))
(define LOOP_HEAD (unique-label))
(define L_CALL (unique-label))
(list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
(jg (label SL_invalid_args))
(jl CONS_LABEL)
(movl (int nil) ebx)
(jmp DONE_LABEL)
CONS_LABEL
(movl (pcb-ref 'allocation-redline) ebx)
(addl eax ebx)
(addl eax ebx)
(cmpl ebx apr)
(jle LOOP_HEAD)
; overflow
(addl eax esp) ; advance esp to cover args
(pushl cpr) ; push current cp
(pushl eax) ; push argc
(negl eax) ; make argc positive
(addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size
(pushl eax) ; push frame size
(addl eax eax) ; double the number of args
(movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg
(movl (int (argc-convention 1)) eax) ; setup argc
(movl (primref-loc 'do-vararg-overflow) cpr) ; load handler
(jmp L_CALL) ; go to overflow handler
; NEW FRAME
'(int 0) ; if the framesize=0, then the framesize is dynamic
'(current-frame-offset)
'(int 0) ; multiarg rp
(byte 0)
(byte 0)
L_CALL
(indirect-cpr-call)
(popl eax) ; pop framesize and drop it
(popl eax) ; reload argc
(popl cpr) ; reload cp
(subl eax fpr) ; readjust fp
LOOP_HEAD
(movl (int nil) ebx)
CONTINUE_LABEL
(movl ebx (mem disp-cdr apr))
(movl (mem fpr eax) ebx)
(movl ebx (mem disp-car apr))
(movl apr ebx)
(addl (int pair-tag) ebx)
(addl (int pair-size) apr)
(addl (int (fxsll 1 fx-shift)) eax)
(cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax)
(jle CONTINUE_LABEL)
DONE_LABEL
(movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr))
ac))
;;;
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
(define (properize args proper ac)
(cond
[proper ac]
[else
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(handle-vararg (length (cdr args)) ac)]))
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (ClambdaCase x ac)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(record-case x
[(clambda-case info body)
(record-case info
[(case-info L args proper)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(let ([lothers (unique-label)])
(list* `(cmpl ,(argc-convention
(if proper
(length (cdr args))
(length (cddr args))))
,argc-register)
(cond
[proper `(jne ,lothers)]
[(> (argc-convention 0) (argc-convention 1))
`(jle ,lothers)]
[else
`(jge ,lothers)])
(properize args proper
(cons (label L)
(T body (cons lothers ac))))))])]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Clambda x)
(record-case x
[(clambda L case* free*)
(list* (length free*)
(label L)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(let f ([case* case*])
(cond
[(null? case*) (invalid-args-error)]
[else
(ClambdaCase (car case*) (f (cdr case*)))])))]))
(define (invalid-args-error)
`((jmp (label ,SL_invalid_args))))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Program x)
(record-case x
[(codes code* body)
(cons (list* 0
(label (gensym))
(T body '()))
(map Clambda code*))]))
;;;
(Program x))
(define (print-code x)
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
(parameterize ([print-gensym '#t])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(pretty-print (unparse x))))
(define (alt-cogen x)
(verify-new-cogen-input x)
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
(let* (
;[foo (print-code x)]
[x (remove-primcalls x)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
;[foo (printf "1")]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[x (eliminate-fix x)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
;[foo (printf "2")]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[x (normalize-context x)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
;[foo (printf "3")]
;[foo (print-code x)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[x (specify-representation x)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[foo (printf "4")]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[x (impose-calling-convention/evaluation-order x)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[foo (printf "5")]
* passinf 2.2
2007-02-11 19:17:59 -05:00
;[foo (print-code x)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[x (color-by-chaitin x)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[foo (printf "6")]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
;[foo (print-code x)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[ls (flatten-codes x)])
* passing 2.1
2007-02-11 18:52:10 -05:00
(when #t
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
(parameterize ([gensym-prefix "L"]
[print-gensym #f])
(for-each
(lambda (ls)
(newline)
(for-each (lambda (x) (printf " ~s\n" x)) ls))
ls)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
ls))
#|module alt-cogen|#)