diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index dbf6cc3..f086840 100644 --- a/scheme/ikarus.compiler.altcogen.ss +++ b/scheme/ikarus.compiler.altcogen.ss @@ -245,7 +245,7 @@ (define (insert-stack-overflow-check x) (define who 'insert-stack-overflow-check) - (define (NonTail x) + (define (NonTail x) (struct-case x [(constant) #f] [(var) #f] @@ -275,32 +275,78 @@ [(jmpcall label rator arg*) (or (NonTail rator) (ormap NonTail arg*))] [(mvcall rator k) #t] ; punt [else (error who "invalid expr" x)])) - (define (insert-check x) (make-seq (make-primcall '$stack-overflow-check '()) x)) - (define (ClambdaCase x) (struct-case x [(clambda-case info body) (make-clambda-case info (Main body))])) - ;;; (define (Clambda x) (struct-case x [(clambda label case* cp free* name) (make-clambda label (map ClambdaCase case*) cp free* name)])) - ;;; (define (Main x) (if (Tail x) (insert-check x) x)) - ;;; (define (Program x) (struct-case x [(codes code* body) (make-codes (map Clambda code*) (Main body))])) - ;;; (Program x)) + + +(define (insert-dummy-type-annotations x) + (define who 'insert-dummy-type-annotations) + (define (Closure x) + (struct-case x + [(closure code free*) + x] + ;(make-closure (Expr code) (map Var free*))] + [else (error who "not a closure" x)])) + (define (Expr x) + (struct-case x + [(constant i) + (make-known x 'constant i)] + [(var) x] + [(primref op) + (make-known x 'primitive op)] + [(bind lhs* rhs* body) + (make-bind lhs* (map Expr rhs*) (Expr body))] + [(fix lhs* rhs* body) + (make-fix lhs* (map Closure rhs*) (Expr body))] + [(conditional e0 e1 e2) + (make-conditional (Expr e0) (Expr e1) (Expr e2))] + [(seq e0 e1) + (make-seq (Expr e0) (Expr e1))] + [(primcall op arg*) + (make-primcall op (map Expr arg*))] + [(forcall op arg*) + (make-forcall op (map Expr arg*))] + [(funcall rator arg*) + (make-funcall (Expr rator) (map Expr arg*))] + [(jmpcall label rator arg*) + (make-jmpcall label (Expr rator) (map Expr arg*))] + [(mvcall rator k) + (make-mvcall (Expr rator) (Expr k))] + [else (error who "invalid expr" x)])) + (define (ClambdaCase x) + (struct-case x + [(clambda-case info body) + (make-clambda-case info (Expr body))])) + (define (Clambda x) + (struct-case x + [(clambda label case* cp free* name) + (make-clambda label (map ClambdaCase case*) cp free* name)])) + (define (Program x) + (struct-case x + [(codes code* body) + (make-codes (map Clambda code*) (Expr body))])) + (Program x)) + + + (include "pass-specify-rep.ss") (define parameter-registers '(%edi)) @@ -2921,6 +2967,7 @@ [x (eliminate-fix x)] [x (insert-engine-checks x)] [x (insert-stack-overflow-check x)] + ;[x (insert-dummy-type-annotations x)] [x (specify-representation x)] [x (impose-calling-convention/evaluation-order x)] [x (time-it "frame" (lambda () (assign-frame-sizes x)))] diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index ae0d046..f09931a 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -137,7 +137,7 @@ (define-struct assign (lhs rhs)) (define-struct mvcall (producer consumer)) - +(define-struct known (expr type value)) (define-struct shortcut (body handler)) diff --git a/scheme/last-revision b/scheme/last-revision index 0d4b7f5..994cddf 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1476 +1478 diff --git a/scheme/pass-specify-rep.ss b/scheme/pass-specify-rep.ss index b82414a..1599b86 100644 --- a/scheme/pass-specify-rep.ss +++ b/scheme/pass-specify-rep.ss @@ -139,11 +139,14 @@ [else (let-values ([(lhs* rhs* arg*) (S* (cdr ls))]) (let ([a (car ls)]) - (cond - [(constant? a) + (struct-case a + [(known expr type v) + (let ([tmp (unique-var 'tmp)]) + (values (cons tmp lhs*) + (cons (V expr) rhs*) + (cons (make-known tmp type v) arg*)))] + [(constant i) (values lhs* rhs* (cons a arg*))] - ;[(var? a) - ; (values lhs* rhs* (cons a arg*))] [else (let ([t (unique-var 'tmp)]) (values (cons t lhs*) (cons (V a) rhs*) (cons t arg*)))])))])) @@ -348,7 +351,13 @@ [(object? c) (error 'constant-rep "double-wrap")] [else (make-constant (make-object c))]))) - (define (V x) + (define (V x) ;;; erase known values + (struct-case x + [(known x type value) + (unknown-V x)] + [else (unknown-V x)])) + + (define (unknown-V x) (struct-case x [(constant) (constant-rep x)] [(var) x] @@ -396,6 +405,9 @@ [(funcall) (prm '!= (V x) (V (K #f)))] [(jmpcall) (prm '!= (V x) (V (K #f)))] [(forcall) (prm '!= (V x) (V (K #f)))] + [(known expr type val) + ;;; FIXME: suboptimal + (P expr)] [else (error 'cogen-P "invalid pred expr" x)])) (define (E x) @@ -421,6 +433,9 @@ (make-funcall (Function rator) (map V arg*))] [(jmpcall label rator arg*) (make-jmpcall label (V rator) (map V arg*))] + [(known expr type val) + ;;; FIXME: suboptimal + (E expr)] [else (error 'cogen-E "invalid effect expr" x)])) (define (Function x) @@ -476,6 +491,7 @@ (struct-case x [(var) x] [(constant i) (constant-rep x)] + [(known expr type val) (T expr)] [else (error 'cogen-T "invalid" (unparse x))])) (define (ClambdaCase x)