diff options
| -rw-r--r-- | compiler.scm | 153 |
1 files changed, 151 insertions, 2 deletions
diff --git a/compiler.scm b/compiler.scm index 170bddd..3a147a2 100644 --- a/compiler.scm +++ b/compiler.scm @@ -77,6 +77,9 @@ (define (quote? x) (op-eq? x 'quote)) +(define (set? x) + (op-eq? x 'set!)) + (define (primcall-op x) (first x)) @@ -812,6 +815,143 @@ ((pair? x) `(funcall ,@(map annotate-free-variables x))))) +;; Determine if var is mutated (via set!) within an expression. +(define (mutable? var x) + (cond + ((immediate? x) #f) + ((quote? x) #f) + ((variable? x) #f) + ((if? x) + (or (mutable? var (test x)) + (mutable? var (consequent x)) + (mutable? var (alternate x)))) + ((let? x) + ;; First, check if any of the expressions for the variable + ;; bindings mutate the variable. + (or (any (lambda (binding) + (mutable? var (rhs binding))) + (let-bindings x)) + ;; Now check if the body mutates the variable, but not if the + ;; let shadows the variable with a new meaning. + (let ((shadowed? (any (lambda (binding) + (eq? (lhs binding) var)) + (let-bindings x)))) + (if shadowed? + #f + (any (lambda (y) + (mutable? var y)) + (let-body x)))))) + ((primcall? x) + (any (lambda (arg) + (mutable? var arg)) + (cdr x))) + ((lambda? x) + (let ((shadowed? (any (lambda (arg) + (eq? arg var)) + (lambda-args x)))) + (if shadowed? + #f + (mutable? var (lambda-body x))))) + ((set? x) + (eq? (second x) var)) + ((pair? x) + (any (lambda (y) (mutable? var y)) x)))) + +(define* (box-mutable-variables x #:optional (mutable-vars '())) + (cond + ((immediate? x) x) + ((quote? x) x) + ((variable? x) + ;; Mutable variable references must be unboxed. + (if (memq x mutable-vars) + `(vector-ref ,x 0) + x)) + ((if? x) + `(if ,(box-mutable-variables (test x) mutable-vars) + ,(box-mutable-variables (consequent x) mutable-vars) + ,(box-mutable-variables (alternate x) mutable-vars))) + ((let? x) + (let* ((bindings (let-bindings x)) + (mutable-bindings + ;; Find all mutable bindings. + (filter (lambda (binding) + (any (lambda (y) + (mutable? (lhs binding) y)) + (let-body x))) + bindings))) + `(let ,(map (lambda (binding) + (let ((var (lhs binding))) + (list var + ;; Use a 1 element vector to box mutable + ;; variables. + (if (memq var mutable-bindings) + `(vector ,(box-mutable-variables (rhs binding) + mutable-vars)) + (box-mutable-variables (rhs binding) + mutable-vars))))) + bindings) + ,@(let ((mutable-vars* + (fold (lambda (var memo) + ;; If the variable is mutable and not + ;; already in the list of mutable vars + ;; (meaning that this new mutable var is + ;; shadowing another mutable var) then add + ;; it to the list. If the variable isn't + ;; mutable, then remove it from the list of + ;; mutable vars, if present. + (if (memq var mutable-bindings) + (if (not (memq var mutable-vars)) + (cons var memo) + memo) + (delq var memo))) + mutable-vars + bindings))) + (map (lambda (y) + (box-mutable-variables y mutable-vars*)) + (let-body x)))))) + ((lambda? x) + (let* ((args (lambda-args x)) + ;; Mutable arguments get new names. + (args* (filter-map (lambda (arg) + (if (mutable? arg (third x)) + (cons arg (unique-variable)) + (cons arg arg))) + args)) + ;; Remove shadowed bindings. If a mutable var is shadowed + ;; by another mutable var, it will be added back to the + ;; list later. + (mutable-vars* (fold (lambda (arg memo) + (delq arg memo)) + mutable-vars + args))) + `(lambda ,(map cdr args*) + ;; Similar to let, box the values of the renamed args into 1 + ;; element vectors bound to the original names. + (let ,(filter-map (lambda (arg) + (and (not (eq? (car arg) (cdr arg))) + (list (car arg) `(vector ,(cdr arg))))) + args*) + ,(box-mutable-variables (lambda-body x) + (fold (lambda (arg memo) + (if (eq? (car arg) (cdr arg)) + memo + (cons (car arg) memo))) + mutable-vars* + args*)))))) + ((primcall? x) + (cons (primcall-op x) + (map (lambda (arg) + (box-mutable-variables arg mutable-vars)) + (primcall-operands x)))) + ((set? x) + ;; Calls to set! are simply transformed to calls to vector-set! to + ;; modify the item inside the box. + `(vector-set! ,(second x) 0 ,(third x))) + ((pair? x) + (map (lambda (y) + (box-mutable-variables y mutable-vars)) + x)))) + ;; Transforms a quote form into code. (define (expand-quote x) (cond @@ -956,7 +1096,8 @@ (parameterize ((unique-counter 0)) (mark-tail-calls (convert-closures-and-constants - (annotate-free-variables x))))) + (annotate-free-variables + (box-mutable-variables x)))))) ;;; @@ -1080,4 +1221,12 @@ ;; complex constants (test-case '(let ((f (lambda () (quote (1 . "H"))))) (eq? (f) (f))) - "#t")) + "#t") + ;; mutable variables + (test-case '(let ((f (lambda (c) + (cons (lambda (v) (set! c v)) + (lambda () c))))) + (let ((p (f 0))) + ((car p) 12) + ((cdr p)))) + "12")) |