diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index d97ead911..8f048a504 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -507,6 +507,28 @@ ($continue ktag0 src ($primcall 'allocate-words/immediate '(box . 2) ())))))) +(define-primcall-converter %box-ref + (lambda (cps k src op param box) + (define unbound + #(misc-error "variable-ref" "Unbound variable: ~S")) + (with-cps cps + (letv val) + (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box)))) + (letk kbound ($kargs () () ($continue k src ($values (val))))) + (letk ktest + ($kargs ('val) (val) + ($branch kbound kunbound src 'undefined? #f (val)))) + (build-term + ($continue ktest src + ($primcall 'scm-ref/immediate '(box . 1) (box))))))) + +(define-primcall-converter %box-set! + (lambda (cps k src op param box val) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val))))))) + (define (ensure-box cps src op x is-box) (define not-box (vector 'wrong-type-arg @@ -521,31 +543,17 @@ (define-primcall-converter box-ref (lambda (cps k src op param box) - (define unbound - #(misc-error "variable-ref" "Unbound variable: ~S")) (ensure-box cps src 'variable-ref box (lambda (cps) - (with-cps cps - (letv val) - (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box)))) - (letk kbound ($kargs () () ($continue k src ($values (val))))) - (letk ktest - ($kargs ('val) (val) - ($branch kbound kunbound src 'undefined? #f (val)))) - (build-term - ($continue ktest src - ($primcall 'scm-ref/immediate '(box . 1) (box))))))))) + (convert-primcall cps k src '%box-ref param box))))) (define-primcall-converter box-set! (lambda (cps k src op param box val) (ensure-box cps src 'variable-set! box (lambda (cps) - (with-cps cps - (build-term - ($continue k src - ($primcall 'scm-set!/immediate '(box . 1) (box val))))))))) + (convert-primcall cps k src '%box-set! param box val))))) (define (ensure-struct cps src op x have-vtable) (define not-struct diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm index 17afa0d1e..beb29b99e 100644 --- a/module/language/tree-il/cps-primitives.scm +++ b/module/language/tree-il/cps-primitives.scm @@ -48,9 +48,11 @@ (define-cps-primitive box 1 1) (define-cps-primitive (variable-ref box-ref) 1 1) (define-cps-primitive (variable-set! box-set!) 2 0) +(define-cps-primitive (%variable-ref %box-ref) 1 1) +(define-cps-primitive (%variable-set! %box-set!) 2 0) (define-cps-primitive current-module 0 1) -(define-cps-primitive define! 1 1) +(define-cps-primitive (module-ensure-local-variable! define!) 2 1) (define-cps-primitive wind 2 0) (define-cps-primitive unwind 0 0) diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm index 05016a3a1..6e5ff33a0 100644 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@ -416,6 +416,15 @@ of an expression." (cause &type-check) (cause &variable))) + (($ _ '%variable-ref (v)) + (logior (compute-effects v) + (cause &type-check) ;; For the unbound check. + &variable)) + (($ _ '%variable-set! (v x)) + (logior (compute-effects v) + (compute-effects x) + (cause &variable))) + (($ _ 'struct-ref (s n)) (logior (compute-effects s) (compute-effects n) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index a2ea9ada9..b7bd4fb8f 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -398,6 +398,12 @@ (make-primcall src 'list (cons message args)) (make-const src #f))))))) +(define-primitive-expander define! (sym val) + (%variable-set! (module-ensure-local-variable! (current-module) sym) val)) + +(define-primitive-expander module-define! (mod sym val) + (%variable-set! (module-ensure-local-variable! mod sym) val)) + (define-primitive-expander zero? (x) (= x 0))