diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index a2157ecc1..4105bfa11 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -341,7 +341,8 @@ the LABELS that are clobbered by the effects of LABEL." ;; FIXME: Flesh this out. (match annotation ('pair &pair) - ('vector &vector))) + ('vector &vector) + ('box &box))) (define-primitive-effects* param ((allocate-words size) (&allocate (annotation->memory-kind param))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index dea81b6bd..161035624 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -91,7 +91,8 @@ (lambda (cps box) (with-cps cps (build-term - ($continue k src ($primcall 'box-ref #f (box)))))))) + ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))))) (define (builtin-ref cps idx k src) (with-cps cps @@ -257,7 +258,7 @@ (letv n*) (letk kop ($kargs ('n) (n*) ($continue k src - ($primcall 'allocate-words ann (n))))) + ($primcall 'allocate-words ann (n*))))) (setk label ($kargs names vars ($continue kop src ($primcall 'load-u64 n ()))))))))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index a5f1aee77..9767ee45b 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -108,10 +108,10 @@ (define (rename name) (build-exp ($primcall name param args))) (define-syntax compute-constant - (syntax-rules (->) - ((_ (c -> exp) body) + (syntax-rules () + ((_ (c exp) body) (let* ((c (intmap-ref constants c)) (c exp)) body)) - ((_ c body) (compute-constant (c -> c) body)))) + ((_ c body) (compute-constant (c c) body)))) (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...) (match (cons name args) (pat @@ -125,11 +125,11 @@ (('allocate-struct v (? uint? n)) (allocate-struct/immediate n (v))) (('struct-ref s (? uint? n)) (struct-ref/immediate n (s))) (('struct-set! s (? uint? n) x) (struct-set!/immediate n (s x))) - (('allocate-words (? uint? n)) (allocate-words/immediate (n -> (cons param n)) ())) - (('scm-ref o (? uint? i)) (scm-ref/immediate (i -> (cons param i)) (o))) - (('scm-set! o (? uint? i) x) (scm-set!/immediate (i -> (cons param i)) (o x))) - (('word-ref o (? uint? i)) (word-ref/immediate (i -> (cons param i)) (o))) - (('word-set! o (? uint? i) x) (word-set!/immediate (i -> (cons param i)) (o x))) + (('allocate-words (? uint? n)) (allocate-words/immediate (n (cons param n)) ())) + (('scm-ref o (? uint? i)) (scm-ref/immediate (i (cons param i)) (o))) + (('scm-set! o (? uint? i) x) (scm-set!/immediate (i (cons param i)) (o x))) + (('word-ref o (? uint? i)) (word-ref/immediate (i (cons param i)) (o))) + (('word-set! o (? uint? i) x) (word-set!/immediate (i (cons param i)) (o x))) (('add x (? num? y)) (add/immediate y (x))) (('add (? num? y) x) (add/immediate y (x))) (('sub x (? num? y)) (sub/immediate y (x))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index efe86be1f..62c9d50ed 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -712,7 +712,8 @@ minimum, and maximum." (define (annotation->type ann) ;; Expand me! (match ann - ('vector &vector))) + ('vector &vector) + ('box &box))) (define-type-inferrer/param (allocate-words param size result) (define! result (annotation->type param) (&min/0 size) (&max/scm-size size))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 786b96552..624cbd6d2 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -360,7 +360,8 @@ (letv unboxed) (let$ body (k unboxed)) (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) - (build-term ($continue kunboxed src ($primcall 'box-ref #f (box)))))) + (build-term ($continue kunboxed src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))) ((orig-var subst-var #f) (k cps subst-var)) (var (k cps var)))) ((? single-valued?) @@ -411,7 +412,8 @@ (with-cps cps (let$ k (adapt-arity k src 1)) (rewrite-term (hashq-ref subst sym) - ((orig-var box #t) ($continue k src ($primcall 'box-ref #f (box)))) + ((orig-var box #t) ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))) ((orig-var subst-var #f) ($continue k src ($values (subst-var)))) (var ($continue k src ($values (var))))))) @@ -491,7 +493,8 @@ (lambda (cps box) (with-cps cps (let$ k (adapt-arity k src 1)) - (build-term ($continue k src ($primcall 'box-ref #f (box)))))))) + (build-term ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))))) (($ src mod name public? exp) (convert-arg cps exp @@ -502,7 +505,8 @@ (with-cps cps (let$ k (adapt-arity k src 0)) (build-term - ($continue k src ($primcall 'box-set! #f (box val)))))))))) + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))) (($ src name) (toplevel-box @@ -510,7 +514,9 @@ (lambda (cps box) (with-cps cps (let$ k (adapt-arity k src 1)) - (build-term ($continue k src ($primcall 'box-ref #f (box)))))))) + (build-term + ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))))) (($ src name exp) (convert-arg cps exp @@ -521,7 +527,8 @@ (with-cps cps (let$ k (adapt-arity k src 0)) (build-term - ($continue k src ($primcall 'box-set! #f (box val)))))))))) + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))) (($ src name exp) (convert-arg cps exp @@ -530,7 +537,8 @@ (let$ k (adapt-arity k src 0)) (letv box) (letk kset ($kargs ('box) (box) - ($continue k src ($primcall 'box-set! #f (box val))))) + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val))))) ($ (with-cps-constants ((name name)) (build-term ($continue kset src ($primcall 'define! #f (name)))))))))) @@ -921,7 +929,8 @@ (with-cps cps (let$ k (adapt-arity k src 0)) (build-term - ($continue k src ($primcall 'box-set! #f (box exp)))))))))) + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box exp)))))))))) (($ src head tail) (if (zero-valued? head)