diff --git a/module/Makefile.am b/module/Makefile.am index c47d0b4..b07c342 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -101,6 +101,7 @@ SCHEME_LANG_SOURCES = \ language/scheme/decompile-tree-il.scm TREE_IL_LANG_SOURCES = \ + language/tree-il/special.scm \ language/tree-il/primitives.scm \ language/tree-il/effects.scm \ language/tree-il/fix-letrec.scm \ @@ -337,6 +338,7 @@ OOP_SOURCES = \ oop/goops/simple.scm SYSTEM_SOURCES = \ + system/vm/special-variable.scm \ system/vm/inspect.scm \ system/vm/coverage.scm \ system/vm/frame.scm \ diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index badce9f..50d64b8 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -151,7 +151,7 @@ (hashq-set! res k v) res)) -(define (analyze-lexicals x) +(define* (analyze-lexicals x #:optional (special-vars #f)) ;; bound-vars: lambda -> (sym ...) ;; all identifiers bound within a lambda (define bound-vars (make-hash-table)) @@ -159,6 +159,9 @@ ;; all identifiers referenced in a lambda, but not bound ;; NB, this includes identifiers referenced by contained lambdas (define free-vars (make-hash-table)) + ;; free-syms: sym -> #t + ;; All variables that is free with respect to a lambda. + (define free-syms (make-hash-table)) ;; assigned: sym -> #t ;; variables that are assigned (define assigned (make-hash-table)) @@ -180,7 +183,7 @@ (analyze! x new-proc (append labels labels-in-proc) #t #f)) (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) (record-case x - (( proc args) + (( proc args) (apply lset-union eq? (step-tail-call proc args) (map step args))) @@ -236,6 +239,9 @@ (let ((free (recur body x))) (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) + (for-each (lambda (var) + (hashq-set! free-syms var #t)) + free) free)) (( opt kw inits gensyms body alternate) @@ -286,7 +292,8 @@ ;; recur/labels instead of recur (hashq-set! bound-vars x '()) (let ((free (recur/labels body x gensyms))) - (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) + (hashq-set! bound-vars x + (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) free)))) vals)) @@ -330,7 +337,11 @@ (append (hashq-ref bound-vars val) (hashq-ref bound-vars proc))) (hashq-remove! bound-vars val) - (hashq-remove! free-vars val)))) + (hashq-remove! free-vars val)) + ;; Else we will allocate a closure; register the free-syms + (for-each (lambda (sym) + (hashq-set! free-syms sym #t)) + (hashq-ref free-vars val)))) gensyms vals) (lset-difference eq? (apply lset-union eq? body-refs var-refs) @@ -395,7 +406,12 @@ (begin (hashq-set! (hashq-ref allocation (car c)) x - `(#f ,(hashq-ref assigned (car c)) . ,n)) + `(#f ,(and (hashq-ref assigned (car c)) + (not (and special-vars + (hashq-ref special-vars (car c)) + (not (hashq-ref free-syms + (car c)))))) + . ,n)) (lp (cdr c) (1+ n))))) (let ((nlocs (allocate! body x 0)) @@ -427,7 +443,15 @@ (begin (hashq-set! allocation (car gensyms) (make-hashq - proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n))) + proc `(#t + ,(and (hashq-ref assigned (car gensyms)) + (not (and special-vars + (hashq-ref special-vars + (car gensyms)) + (not (hashq-ref + free-syms + (car gensyms)))))) + . ,n))) (lp (cdr gensyms) (1+ n))))) (if alternate (allocate! alternate proc n) n))) @@ -456,7 +480,12 @@ (hashq-set! allocation v (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) + `(#t ,(and (hashq-ref assigned v) + (not (and special-vars + (hashq-ref special-vars v) + (not (hashq-ref free-syms + v))))) + . ,n))) (lp (cdr gensyms) (1+ n))))))))) (( gensyms vals body) @@ -471,7 +500,12 @@ (hashq-set! allocation v (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) + `(#t ,(and (hashq-ref assigned v) + (not (and special-vars + (hashq-ref special-vars v) + (not (hashq-ref free-syms + v))))) + . ,n))) (lp (cdr gensyms) (1+ n)))))) (( gensyms vals body) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e4df6e1..7321fb1 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -29,6 +29,7 @@ #:use-module (language tree-il optimize) #:use-module (language tree-il canonicalize) #:use-module (language tree-il analyze) + #:use-module (language tree-il special) #:use-module ((srfi srfi-1) #:select (filter-map)) #:export (compile-glil)) @@ -64,9 +65,10 @@ (let* ((x (make-lambda (tree-il-src x) '() (make-lambda-case #f '() #f #f #f '() '() x #f))) - (x (optimize! x e opts)) + (x (optimize! (optimize! x e opts) e opts)) (x (canonicalize! x)) - (allocation (analyze-lexicals x))) + (special-vars (register-special-vars x)) + (allocation (analyze-lexicals x special-vars))) (with-fluids ((*comp-module* e)) (values (flatten-lambda x #f allocation) diff --git a/module/language/tree-il/special.scm b/module/language/tree-il/special.scm new file mode 100644 index 0000000..0e38084 --- /dev/null +++ b/module/language/tree-il/special.scm @@ -0,0 +1,104 @@ +(define-module (language tree-il special) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (system base syntax) + #:use-module (system base message) + #:use-module (system vm program) + #:use-module (language tree-il) + #:use-module (system base pmatch) + #:export (register-special-vars)) + + +(define (register-special-vars x) + (define register (make-hash-table)) + (let lp ((x x)) + (record-case x + (( proc args) + (record-case proc + (( src mod name public?) + (if (and (equal? mod '(system vm special-variable)) + (eq? name 'special) + (= (length args) 1)) + (record-case (car args) + (( src gensym) + (hashq-set! register gensym #t)) + (else #t)))) + (else #f)) + (lp proc) + (for-each lp args)) + + (( test consequent alternate) + (lp test) + (lp consequent) + (lp alternate)) + + + (( gensym exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exps) + (for-each lp exps)) + + (( body) + (lp body)) + + (( opt kw inits gensyms body alternate) + (for-each lp inits) + (lp body) + (if alternate (lp alternate))) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( exp body) + (lp exp) + (lp body)) + + (( body winder unwinder) + (lp body) + (lp winder) + (lp unwinder)) + + (( fluids vals body) + (lp body) + (for-each lp (append fluids vals))) + + (( fluid) + (lp fluid)) + + (( fluid exp) + (lp fluid) (lp exp)) + + (( tag body handler) + (lp tag) + (lp body) + (lp handler)) + + (( tag args tail) + (lp tag) (lp tail) (for-each lp args)) + + (else #t))) + register) + diff --git a/module/system/vm/special-variable.scm b/module/system/vm/special-variable.scm new file mode 100644 index 0000000..2068b84 --- /dev/null +++ b/module/system/vm/special-variable.scm @@ -0,0 +1,9 @@ +(define-module (system vm special-variable) + #:export (mark-as-special)) + +(define special (lambda (x) #f)) + +(define-syntax-rule (mark-as-special v ...) + (begin + (special v) + ...))