* removed more junk.
This commit is contained in:
Abdulaziz Ghuloum
parent
665f3a0b79
commit
39e6fc2fcf
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -532,7 +532,7 @@
|
|||
(cond
|
||||
[(null? ls) (make-constant '())]
|
||||
[else
|
||||
(make-primcall 'cons
|
||||
(make-funcall (make-primref 'cons)
|
||||
(list (car ls) (make-conses (cdr ls))))]))
|
||||
(define (properize lhs* rhs*)
|
||||
(cond
|
||||
|
|
@ -635,8 +635,6 @@
|
|||
(make-clambda-case info (Expr body))]))
|
||||
cls*)
|
||||
#f)]
|
||||
[(primcall rator rand*)
|
||||
(make-primcall rator (map Expr rand*))]
|
||||
[(funcall rator rand*)
|
||||
(inline (Expr rator) (map Expr rand*))]
|
||||
[(forcall rator rand*)
|
||||
|
|
@ -711,7 +709,7 @@
|
|||
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
|
||||
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
|
||||
(partition-rhs* 0 lhs* rhs* vref vcomp)])
|
||||
(let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)])
|
||||
(let ([v* (map (lambda (x) (make-constant (void))) clhs*)])
|
||||
(make-bind slhs* srhs*
|
||||
(make-bind clhs* v*
|
||||
(make-fix llhs* lrhs*
|
||||
|
|
@ -762,10 +760,6 @@
|
|||
(make-clambda-case info body)))]))
|
||||
cls*)
|
||||
#f)]
|
||||
[(primcall rator rand*)
|
||||
(unless (memq rator simple-primitives)
|
||||
(comp))
|
||||
(make-primcall rator (E* rand* ref comp))]
|
||||
[(funcall rator rand*)
|
||||
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
|
||||
(record-case rator
|
||||
|
|
@ -860,6 +854,7 @@
|
|||
645 list
|
||||
|#
|
||||
|
||||
|
||||
;;; FIXME URGENT: should handle (+ x k), (- x k) where k is a fixnum
|
||||
;;; also fx+, fx-
|
||||
(module (optimize-primcall)
|
||||
|
|
@ -972,7 +967,7 @@
|
|||
(mk-seq a1
|
||||
(optimize-primcall ctxt 'eq?
|
||||
(list a0 (make-constant (car ls)))))]
|
||||
[else (make-primcall '$memq rand*)])))))
|
||||
[else (make-funcall (make-primref '$memq) rand*)])))))
|
||||
(giveup))]
|
||||
[(list)
|
||||
(case ctxt
|
||||
|
|
@ -1031,9 +1026,9 @@
|
|||
(or (constant-value a1
|
||||
(lambda (n1)
|
||||
(mk-seq a1
|
||||
(make-primcall op
|
||||
(make-funcall (make-primref op)
|
||||
(list a0 (make-constant n1))))))
|
||||
(make-primcall op rand*))])))
|
||||
(make-funcall (make-primref op) rand*))])))
|
||||
(error 'optimize "~s rands to ~s" (map unparse rand*) op))]
|
||||
[(void)
|
||||
(or (and (null? rand*)
|
||||
|
|
@ -1063,7 +1058,7 @@
|
|||
(mk-seq a
|
||||
(make-constant
|
||||
(cadr v))))))
|
||||
(make-primcall op rand*))))
|
||||
(make-funcall (make-primref op) rand*))))
|
||||
(giveup))]
|
||||
[(not null? pair? fixnum? vector? string? char? symbol?
|
||||
eof-object?)
|
||||
|
|
@ -1089,7 +1084,7 @@
|
|||
[else
|
||||
(error 'optimize
|
||||
"huh ~s" op)])))))
|
||||
(make-primcall op rand*))])))
|
||||
(make-funcall (make-primref op) rand*))])))
|
||||
(giveup))]
|
||||
[($car $cdr)
|
||||
(or (and (fx= (length rand*) 1)
|
||||
|
|
@ -1121,7 +1116,7 @@
|
|||
(and (fixnum? t)
|
||||
(mk-seq a
|
||||
(make-constant t)))))))
|
||||
(make-primcall op rand*))))
|
||||
(make-funcall (make-primref op) rand*))))
|
||||
(giveup))]
|
||||
[(fx+)
|
||||
(or (and (fx= (length rand*) 2)
|
||||
|
|
@ -1137,15 +1132,15 @@
|
|||
(mk-seq (mk-seq a0 a1)
|
||||
(make-constant r)))))))
|
||||
(mk-seq a1
|
||||
(make-primcall op
|
||||
(make-funcall (make-primref op)
|
||||
(list a0 (make-constant v1))))))))
|
||||
(constant-value a0
|
||||
(lambda (v0)
|
||||
(and (fixnum? v0)
|
||||
(mk-seq a0
|
||||
(make-primcall op
|
||||
(make-funcall (make-primref op)
|
||||
(list (make-constant v0) a1))))))
|
||||
(make-primcall op rand*))))
|
||||
(make-funcall (make-primref op) rand*))))
|
||||
(giveup))]
|
||||
;X; [(fx- fx+ fx*)
|
||||
;X; (or (and (fx= (length rand*) 2)
|
||||
|
|
@ -1190,7 +1185,7 @@
|
|||
|
||||
(define (copy-propagate x)
|
||||
(define who 'copy-propagate)
|
||||
(define the-void (make-primcall 'void '()))
|
||||
(define the-void (make-constant (void)))
|
||||
(define (known-value x)
|
||||
(record-case x
|
||||
[(constant) x] ; known
|
||||
|
|
@ -1463,7 +1458,7 @@
|
|||
[(null? lhs*) body]
|
||||
[else
|
||||
(make-bind lhs*
|
||||
(map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*)
|
||||
(map (lambda (rhs) (make-funcall (make-primref 'vector) (list rhs))) rhs*)
|
||||
body)]))
|
||||
(define (Expr x)
|
||||
(record-case x
|
||||
|
|
@ -1471,7 +1466,7 @@
|
|||
[(var)
|
||||
(cond
|
||||
[(var-assigned x)
|
||||
(make-primcall '$vector-ref (list x (make-constant 0)))]
|
||||
(make-funcall (make-primref '$vector-ref) (list x (make-constant 0)))]
|
||||
[else x])]
|
||||
[(primref) x]
|
||||
[(bind lhs* rhs* body)
|
||||
|
|
@ -1496,8 +1491,6 @@
|
|||
(bind-assigned a-lhs* a-rhs* (Expr body))))])]))
|
||||
cls*)
|
||||
#f)]
|
||||
[(primcall op rand*)
|
||||
(make-primcall op (map Expr rand*))]
|
||||
[(forcall op rand*)
|
||||
(make-forcall op (map Expr rand*))]
|
||||
[(funcall rator rand*)
|
||||
|
|
@ -1505,7 +1498,8 @@
|
|||
[(assign lhs rhs)
|
||||
(unless (var-assigned lhs)
|
||||
(error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
|
||||
(make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))]
|
||||
(make-funcall (make-primref '$vector-set!)
|
||||
(list lhs (make-constant 0) (Expr rhs)))]
|
||||
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
|
||||
[else (error who "invalid expression ~s" (unparse x))]))
|
||||
(Expr x))
|
||||
|
|
@ -1551,7 +1545,7 @@
|
|||
(let f ([fml* (cdr fml*)] [rand* rand*])
|
||||
(cond
|
||||
[(null? fml*)
|
||||
(list (make-primcall 'list rand*))]
|
||||
(list (make-funcall (make-primref 'list) rand*))]
|
||||
[else
|
||||
(cons (car rand*)
|
||||
(f (cdr fml*) (cdr rand*)))])))
|
||||
|
|
@ -1581,8 +1575,6 @@
|
|||
(make-clambda-case info (Expr body))]))
|
||||
cls*)
|
||||
#f)]
|
||||
[(primcall op rand*)
|
||||
(make-primcall op (map Expr rand*))]
|
||||
[(forcall op rand*)
|
||||
(make-forcall op (map Expr rand*))]
|
||||
[(funcall rator rand*)
|
||||
|
|
@ -1666,9 +1658,6 @@
|
|||
(values (make-seq e0 e1) (union e0-free e1-free)))]
|
||||
[(clambda)
|
||||
(do-clambda ex)]
|
||||
[(primcall op rand*)
|
||||
(let-values ([(rand* rand*-free) (Expr* rand*)])
|
||||
(values (make-primcall op rand*) rand*-free))]
|
||||
[(forcall op rand*)
|
||||
(let-values ([(rand* rand*-free) (Expr* rand*)])
|
||||
(values (make-forcall op rand*) rand*-free))]
|
||||
|
|
@ -1830,7 +1819,6 @@
|
|||
(make-conditional (E test) (E conseq) (E altern))]
|
||||
[(seq e0 e1) (make-seq (E e0) (E e1))]
|
||||
[(closure c free) (optimize-one-closure c free)]
|
||||
[(primcall op rand*) (make-primcall op (map E rand*))]
|
||||
[(forcall op rand*) (make-forcall op (map E rand*))]
|
||||
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
|
||||
[(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))]
|
||||
|
|
@ -1853,7 +1841,7 @@
|
|||
(include "libcogen1.ss")
|
||||
|
||||
|
||||
(define (insert-engine-checks x)
|
||||
(define (insert-engine-checks-not-working x)
|
||||
(define (Tail x)
|
||||
(make-seq
|
||||
(make-interrupt-call
|
||||
|
|
@ -2430,17 +2418,6 @@
|
|||
(tail-indirect-cpr-call))))
|
||||
SL_fx+_overflow]))
|
||||
|
||||
(define (alt-compile-core-expr->code p)
|
||||
(let* ([p (recordize p)]
|
||||
[p (optimize-direct-calls p)]
|
||||
[p (optimize-letrec p)]
|
||||
[p (uncover-assigned/referenced p)]
|
||||
[p (copy-propagate p)]
|
||||
[p (rewrite-assignments p)]
|
||||
[p (optimize-for-direct-jumps p)]
|
||||
[p (convert-closures p)]
|
||||
[p (optimize-closures/lift-codes p)])
|
||||
p ))
|
||||
|
||||
(define (compile-core-expr->code p)
|
||||
(let* ([p (recordize p)]
|
||||
|
|
|
|||
|
|
@ -21,103 +21,6 @@
|
|||
;;; <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 (check-jmp-target x)
|
||||
(unless (or (gensym? x)
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'symbol-code)
|
||||
(symbol? (cdr x))))
|
||||
(error who "invalid jmp target")))
|
||||
;;;
|
||||
(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-jmp-target label)
|
||||
(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))
|
||||
|
||||
|
||||
(module (must-open-code? prim-context)
|
||||
|
|
@ -298,9 +201,9 @@
|
|||
;;; whole primcall business.
|
||||
|
||||
|
||||
(define (remove-primcalls x)
|
||||
(define (introduce-primcalls x)
|
||||
;;;
|
||||
(define who 'remove-primcalls)
|
||||
(define who 'introduce-primcalls)
|
||||
;;;
|
||||
(define (check-gensym x)
|
||||
(unless (gensym? x)
|
||||
|
|
@ -351,8 +254,6 @@
|
|||
[(seq e0 e1)
|
||||
(make-seq (Expr e0) (Expr e1))]
|
||||
[(closure) x]
|
||||
[(primcall op arg*)
|
||||
(mkfuncall (make-primref op) (map Expr arg*))]
|
||||
[(forcall op arg*)
|
||||
(make-forcall op (map Expr arg*))]
|
||||
[(funcall rator arg*)
|
||||
|
|
@ -2931,24 +2832,13 @@
|
|||
(define (alt-cogen x)
|
||||
(define (time-it name proc)
|
||||
(proc))
|
||||
;(verify-new-cogen-input x)
|
||||
(let* (
|
||||
;[foo (printf "0")]
|
||||
[x (remove-primcalls x)]
|
||||
;[foo (printf "1")]
|
||||
[x (eliminate-fix x)]
|
||||
;[foo (printf "2")]
|
||||
[x (specify-representation x)]
|
||||
;[foo (printf "4")]
|
||||
[x (impose-calling-convention/evaluation-order x)]
|
||||
;[foo (printf "5")]
|
||||
[x (time-it "frame" (lambda () (assign-frame-sizes x)))]
|
||||
;[foo (printf "6")]
|
||||
[x (time-it "register" (lambda () (color-by-chaitin x)))]
|
||||
;[foo (printf "7")]
|
||||
[ls (flatten-codes x)]
|
||||
;[foo (printf "8")]
|
||||
)
|
||||
(let* ([x (introduce-primcalls x)]
|
||||
[x (eliminate-fix x)]
|
||||
[x (specify-representation x)]
|
||||
[x (impose-calling-convention/evaluation-order x)]
|
||||
[x (time-it "frame" (lambda () (assign-frame-sizes x)))]
|
||||
[x (time-it "register" (lambda () (color-by-chaitin x)))]
|
||||
[ls (flatten-codes x)])
|
||||
ls))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue