suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

keeping track of closure names

Browse Source
This commit is contained in:
Danny Yoo 2011-03-14 18:53:05 -04:00
parent 70d0cccce6
commit 77f90ba95c
9 changed files with 171 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
assemble.rkt
View File

@ -354,7 +354,7 @@ EOF
;; during install-closure-values. ;; during install-closure-values.
(reverse (MakeCompiledProcedure-closed-vals op))) (reverse (MakeCompiledProcedure-closed-vals op)))
", ") ", ")
(symbol->string (MakeCompiledProcedure-label op)))] (symbol->string (MakeCompiledProcedure-display-name op)))]
[(ApplyPrimitiveProcedure? op) [(ApplyPrimitiveProcedure? op)
(format "MACHINE.proc(~a, ~a)" (format "MACHINE.proc(~a, ~a)"

65
compile.rkt
View File

@ -16,6 +16,11 @@
call/cc-label call/cc-label
make-call/cc-code) make-call/cc-code)
(: current-defined-name (Parameterof (U Symbol False)))
(define current-defined-name (make-parameter #f))
;(provide compile-top) ;(provide compile-top)
(: -compile (ExpressionCore Target Linkage -> (Listof Statement))) (: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
@ -184,10 +189,11 @@
(error 'compile-definition "Defintion not at toplevel")] (error 'compile-definition "Defintion not at toplevel")]
[(PrefixAddress? lexical-pos) [(PrefixAddress? lexical-pos)
(let ([get-value-code (let ([get-value-code
(compile (Def-value exp) cenv (make-EnvPrefixReference (parameterize ([current-defined-name var])
(PrefixAddress-depth lexical-pos) (compile (Def-value exp) cenv (make-EnvPrefixReference
(PrefixAddress-pos lexical-pos)) (PrefixAddress-depth lexical-pos)
'next)]) (PrefixAddress-pos lexical-pos))
'next))])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -255,7 +261,8 @@
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement target
(make-MakeCompiledProcedure proc-entry (make-MakeCompiledProcedure proc-entry
(length (Lam-parameters exp)) (length (Lam-parameters exp))
lexical-references))))) lexical-references
(current-defined-name))))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
lexical-references lexical-references
free-vars free-vars
@ -489,10 +496,11 @@
(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let1 exp cenv target linkage) (define (compile-let1 exp cenv target linkage)
(let*: ([rhs-code : InstructionSequence (let*: ([rhs-code : InstructionSequence
(compile (Let1-rhs exp) (parameterize ([current-defined-name (Let1-name exp)])
(extend-lexical-environment/placeholders cenv 1) (compile (Let1-rhs exp)
(make-EnvLexicalReference 0 #f) (extend-lexical-environment/placeholders cenv 1)
'next)] (make-EnvLexicalReference 0 #f)
'next))]
[after-let1 : Symbol (make-label 'afterLetOne)] [after-let1 : Symbol (make-label 'afterLetOne)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment [extended-cenv : CompileTimeEnvironment
@ -526,15 +534,16 @@
(let*: ([n : Natural (length (Let-rhss exp))] (let*: ([n : Natural (length (Let-rhss exp))]
[rhs-codes : (Listof InstructionSequence) [rhs-codes : (Listof InstructionSequence)
(map (lambda: ([rhs : ExpressionCore] (map (lambda: ([rhs : ExpressionCore]
[i : Natural]) [i : Natural]
(compile rhs [name : Symbol])
(extend-lexical-environment/placeholders cenv n) (parameterize ([current-defined-name name])
(make-EnvLexicalReference i #f) (compile rhs
'next)) (extend-lexical-environment/placeholders cenv n)
(make-EnvLexicalReference i #f)
'next)))
(Let-rhss exp) (Let-rhss exp)
(build-list n (build-list n (lambda: ([i : Natural]) i))
(lambda: ([i : Natural]) (Let-names exp))]
i)))]
[after-let : Symbol (make-label 'afterLet)] [after-let : Symbol (make-label 'afterLet)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment [extended-cenv : CompileTimeEnvironment
@ -566,16 +575,17 @@
(let*: ([n : Natural (length (LetRec-rhss exp))] (let*: ([n : Natural (length (LetRec-rhss exp))]
[rhs-codes : (Listof InstructionSequence) [rhs-codes : (Listof InstructionSequence)
(map (lambda: ([rhs : ExpressionCore] (map (lambda: ([rhs : ExpressionCore]
[i : Natural]) [i : Natural]
(compile rhs [name : Symbol])
(extend-lexical-environment/boxed-names cenv (parameterize ([current-defined-name name])
(LetRec-names exp)) (compile rhs
(make-EnvLexicalReference i #t) (extend-lexical-environment/boxed-names cenv
'next)) (LetRec-names exp))
(make-EnvLexicalReference i #t)
'next)))
(LetRec-rhss exp) (LetRec-rhss exp)
(build-list n (build-list n (lambda: ([i : Natural]) i))
(lambda: ([i : Natural]) (LetRec-names exp))]
i)))]
[after-letrec : Symbol (make-label 'afterLetRec)] [after-letrec : Symbol (make-label 'afterLetRec)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment [extended-cenv : CompileTimeEnvironment
@ -679,7 +689,8 @@
(make-MakeCompiledProcedure call/cc-closure-entry (make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value 1 ;; the continuation consumes a single value
(list (make-EnvLexicalReference 0 #f) (list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f)))) (make-EnvLexicalReference 1 #f))
(current-defined-name)))
,(make-PopEnvironment 2 0))) ,(make-PopEnvironment 2 0)))
;; Finally, do a tail call into f. ;; Finally, do a tail call into f.

3
il-structs.rkt
View File

@ -136,7 +136,8 @@
;; closure needs to close over. ;; closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol] (define-struct: MakeCompiledProcedure ([label : Symbol]
[arity : Natural] [arity : Natural]
[closed-vals : (Listof EnvReference)]) [closed-vals : (Listof EnvReference)]
[display-name : (U Symbol False)])
#:transparent) #:transparent)
;; Applies the primitive procedure that's stored in the proc register, using ;; Applies the primitive procedure that's stored in the proc register, using

5
runtime.js
View File

@ -152,6 +152,11 @@ var Primitives = (function() {
return firstArg - 1; return firstArg - 1;
}, },
'zero?': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg === 0;
},
'vector': function(arity, returnLabel) { 'vector': function(arity, returnLabel) {
var i; var i;
var result = []; var result = [];

57
simulator-primitives.rkt
View File

@ -41,7 +41,8 @@
(define call/cc (define call/cc
(make-closure call/cc-label (make-closure call/cc-label
1 1
'())) '()
'call/cc))
(define call-with-current-continuation call/cc) (define call-with-current-continuation call/cc)
(define e (exp 1)) (define e (exp 1))
@ -66,6 +67,36 @@
(define my-pair? (lambda (x) (define my-pair? (lambda (x)
(MutablePair? x))) (MutablePair? x)))
(define my-box (lambda (x)
(vector x)))
(define my-unbox (lambda (x)
(vector-ref x 0)))
(define my-set-box! (lambda (x v)
(vector-set! x 0 v)))
(define my-vector->list (lambda (v)
(apply my-list (vector->list v))))
(define my-list->vector (lambda (l)
(apply vector
(let loop ([l l])
(cond
[(null? l)
null]
[else
(cons (MutablePair-h l)
(loop (MutablePair-t l)))])))))
(define my-set-car! (lambda (p v)
(set-MutablePair-h! p v)))
(define my-set-cdr! (lambda (p v)
(set-MutablePair-t! p v)))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= (define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >=
sub1 sub1
display newline displayln display newline displayln
@ -74,6 +105,7 @@
eq? eq?
add1 add1
sub1 sub1
zero?
abs abs
void void
quotient quotient
@ -81,14 +113,37 @@
display display
displayln displayln
newline newline
symbol->string symbol->string
string-append
(my-cons cons) (my-cons cons)
(my-list list) (my-list list)
(my-car car) (my-car car)
(my-cdr cdr) (my-cdr cdr)
(my-pair? pair?) (my-pair? pair?)
(my-set-car! set-car!)
(my-set-cdr! set-cdr!)
(my-box box)
(my-unbox unbox)
(my-set-box! set-box!)
vector vector
vector-set!
vector-ref
(my-vector->list vector->list)
(my-list->vector list->vector)
equal?
symbol?) symbol?)
#:constants (null pi e #:constants (null pi e
call/cc call/cc

6
simulator-structs.rkt
View File

@ -24,7 +24,8 @@
(define-struct: MutablePair ([h : PrimitiveValue] (define-struct: MutablePair ([h : PrimitiveValue]
[t : PrimitiveValue])) [t : PrimitiveValue])
#:mutable #:transparent)
;; For continuation capture: ;; For continuation capture:
(define-struct: CapturedControl ([frames : (Listof frame)])) (define-struct: CapturedControl ([frames : (Listof frame)]))
@ -70,7 +71,8 @@
;; Compiled procedure closures ;; Compiled procedure closures
(define-struct: closure ([label : Symbol] (define-struct: closure ([label : Symbol]
[arity : Natural] [arity : Natural]
[vals : (Listof SlotValue)]) [vals : (Listof SlotValue)]
[display-name : (U Symbol False)])
#:transparent) #:transparent)

7
simulator.rkt
View File

@ -191,7 +191,9 @@
(if (= (closure-arity clos) (if (= (closure-arity clos)
(CheckClosureArity!-arity op)) (CheckClosureArity!-arity op))
'ok 'ok
(error 'check-closure-arity "arity mismatch"))] (error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
(CheckClosureArity!-arity op)
(closure-display-name clos)))]
[else [else
(error 'check-closure-arity "not a closure: ~s" clos)]))] (error 'check-closure-arity "not a closure: ~s" clos)]))]
@ -263,7 +265,8 @@
(MakeCompiledProcedure-arity op) (MakeCompiledProcedure-arity op)
(map (lambda: ([r : EnvReference]) (map (lambda: ([r : EnvReference])
(lookup-env-reference/closure-capture m r)) (lookup-env-reference/closure-capture m r))
(MakeCompiledProcedure-closed-vals op))))] (MakeCompiledProcedure-closed-vals op))
(MakeCompiledProcedure-display-name op)))]
[(ApplyPrimitiveProcedure? op) [(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)] (let: ([prim : SlotValue (machine-proc m)]

6
test-conform.rkt
View File

@ -15,6 +15,8 @@
#:debug? (debug? false) #:debug? (debug? false)
#:stack-limit (stack-limit false) #:stack-limit (stack-limit false)
#:control-limit (control-limit false)) #:control-limit (control-limit false))
#;(for-each displayln (vector->list (machine-text m)))
(let loop ([steps 0]) (let loop ([steps 0])
(when debug? (when debug?
@ -49,7 +51,7 @@
(printf "Running... \n") (printf "Running... \n")
(let*-values([(a-machine num-steps) (let*-values([(a-machine num-steps)
(run (new-machine (run-compiler code)) options ...)] (run (new-machine (run-compiler code)) options ...)]
[(actual) (machine-val a-machine)]) [(actual) (machine-val a-machine)])
(unless (equal? actual exp) (unless (equal? actual exp)
(raise-syntax-error #f (format "Expected ~s, got ~s" exp actual) (raise-syntax-error #f (format "Expected ~s, got ~s" exp actual)
#'stx)) #'stx))
@ -66,4 +68,4 @@
(test (read (open-input-file "tests/conform/program0.sch")) (test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")) (port->string (open-input-file "tests/conform/expected0.txt"))
#:debug? #t) #:debug? #f)

74
tests/conform/program0.sch
View File

@ -1,4 +1,42 @@
(begin (begin
(define (caar l)
(car (car l)))
(define (map f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))
(define (for-each f l)
(if (null? l)
null
(begin (f (car l))
(for-each f (cdr l)))))
(define (memq x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))
(define (assq x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))
(define (length l)
(if (null? l)
0
(add1 (length (cdr l)))))
(define vector-copy (define vector-copy
(lambda (v) (lambda (v)
(let ((length (vector-length v))) (let ((length (vector-length v)))
@ -241,11 +279,11 @@
(define res (lambda (pair) (cdr pair))) (define res (lambda (pair) (cdr pair)))
(define conforms? (define conforms?
(lambda (t1 t2) (lambda (t1 t2)
(letrec ((nodes-with-red-edges-out '()) (letrec ((nodes-with-red-edges-out (box '()))
(add-red-edge! (add-red-edge!
(lambda (from-node to-node) (lambda (from-node to-node)
(set-red-edges! from-node (adjoin to-node (red-edges from-node))) (set-red-edges! from-node (adjoin to-node (red-edges from-node)))
(set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out)))) (set-box! nodes-with-red-edges-out (adjoin from-node (unbox nodes-with-red-edges-out)))))
(greenify-red-edges! (greenify-red-edges!
(lambda (from-node) (lambda (from-node)
(set-green-edges! from-node (append (red-edges from-node) (green-edges from-node))) (set-green-edges! from-node (append (red-edges from-node) (green-edges from-node)))
@ -279,7 +317,7 @@
loop) loop)
(blue-edges t2)))))))))) (blue-edges t2))))))))))
(let ((result (does-conform t1 t2))) (let ((result (does-conform t1 t2)))
(for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out) (for-each (if result greenify-red-edges! delete-red-edges!) (unbox nodes-with-red-edges-out))
result)))) result))))
(define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f))) (define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f)))
(define classify (define classify
@ -379,7 +417,7 @@
(if (conforms? node2 node1) (if (conforms? node2 node1)
(begin node2) (begin node2)
(begin (begin
(let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")")))) (let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")") '())))
(add-graph-nodes! graph result) (add-graph-nodes! graph result)
(insert! (already-joined graph) node1 node2 result) (insert! (already-joined graph) node1 node2 result)
(set-blue-edges! (set-blue-edges!
@ -411,25 +449,25 @@
(begin (begin
(if print? (begin (display '" -> ") (display new-count) (newline)) (void)) (if print? (begin (display '" -> ") (display new-count) (newline)) (void))
(loop new-g new-count))))))))) (loop new-g new-count)))))))))
(let ((graph (apply make-graph (list (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))) (let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
(loop graph (length (graph-nodes graph))))))) (loop graph (length (graph-nodes graph)))))))
(define a '()) (define a (box '()))
(define b '()) (define b (box '()))
(define c '()) (define c (box '()))
(define d '()) (define d (box '()))
(define reset (define reset
(lambda () (lambda ()
(set! a (make-node 'a '())) (set-box! a (make-node 'a '()))
(set! b (make-node 'b '())) (set-box! b (make-node 'b '()))
(set-blue-edges! a (list (make-blue-edge 'phi any-node b))) (set-blue-edges! (unbox a) (list (make-blue-edge 'phi any-node (unbox b))))
(set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b))) (set-blue-edges! (unbox b) (list (make-blue-edge 'phi any-node (unbox a)) (make-blue-edge 'theta any-node (unbox b))))
(set! c (make-node '"c" '())) (set-box! c (make-node '"c" '()))
(set! d (make-node '"d" '())) (set-box! d (make-node '"d" '()))
(set-blue-edges! c (list (make-blue-edge 'theta any-node b))) (set-blue-edges! (unbox c) (list (make-blue-edge 'theta any-node (unbox b))))
(set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d))) (set-blue-edges! (unbox d) (list (make-blue-edge 'phi any-node (unbox c)) (make-blue-edge 'theta any-node (unbox d))))
'(made a b c d))) '(made a b c d)))
(define test (define test
(lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t))))) (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list (unbox a) (unbox b) (unbox c) (unbox d) any-node none-node)) '#t)))))
(define go (define go
(lambda () (lambda ()
(reset) (reset)