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

checking closures

Browse Source
This commit is contained in:
Danny Yoo 2011-03-07 21:46:13 -05:00
parent 0a7f12375f
commit 4a2f30b4f2
6 changed files with 55 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
compile.rkt
View File

@ -228,6 +228,7 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement target
(make-MakeCompiledProcedure proc-entry (make-MakeCompiledProcedure proc-entry
(length (Lam-parameters exp))
lexical-references))))) lexical-references)))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
lexical-references lexical-references
@ -341,6 +342,8 @@
primitive-branch))) primitive-branch)))
compiled-branch compiled-branch
(make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! n))))
(end-with-compiled-application-linkage (end-with-compiled-application-linkage
compiled-linkage compiled-linkage
cenv cenv

11
il-structs.rkt
View File

@ -113,9 +113,11 @@
(define-struct: GetCompiledProcedureEntry () (define-struct: GetCompiledProcedureEntry ()
#:transparent) #:transparent)
;; Constructs a closure, given the label and the set of lexical references ;; Constructs a closure, given the label, # of expected arguments,
;; into the environment that the closure needs to close over. ;; and the set of lexical references into the environment that the
;; closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol] (define-struct: MakeCompiledProcedure ([label : Symbol]
[arity : Natural]
[closed-vals : (Listof EnvReference)]) [closed-vals : (Listof EnvReference)])
#:transparent) #:transparent)
@ -169,6 +171,10 @@
[name : Symbol]) [name : Symbol])
#:transparent) #:transparent)
;; Check the closure procedure value in 'proc and make sure it can accept n values.
(define-struct: CheckClosureArity! ([arity : Natural])
#:transparent)
;; Extends the environment with a prefix that holds ;; Extends the environment with a prefix that holds
;; lookups to the namespace. ;; lookups to the namespace.
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof Symbol)]) (define-struct: ExtendEnvironment/Prefix! ([names : (Listof Symbol)])
@ -182,6 +188,7 @@
(define-type PrimitiveCommand (U (define-type PrimitiveCommand (U
SetToplevel! SetToplevel!
CheckToplevelBound! CheckToplevelBound!
CheckClosureArity!
ExtendEnvironment/Prefix! ExtendEnvironment/Prefix!
InstallClosureValues!)) InstallClosureValues!))

1
simulator-structs.rkt
View File

@ -44,6 +44,7 @@
;; Compiled procedure closures ;; Compiled procedure closures
(define-struct: closure ([label : Symbol] (define-struct: closure ([label : Symbol]
[arity : Natural]
[vals : (Listof SlotValue)]) [vals : (Listof SlotValue)])
#:transparent) #:transparent)

17
simulator.rkt
View File

@ -152,18 +152,32 @@
(toplevel-mutate (ensure-toplevel (env-ref m (SetToplevel!-depth op))) (toplevel-mutate (ensure-toplevel (env-ref m (SetToplevel!-depth op)))
(SetToplevel!-pos op) (SetToplevel!-pos op)
(ensure-primitive-value (machine-val m))))] (ensure-primitive-value (machine-val m))))]
[(CheckToplevelBound!? op) [(CheckToplevelBound!? op)
(let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))]) (let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))])
(cond (cond
[(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op))) [(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
(error 'check-toplevel-bound! "Unbound identifier ~s" (CheckToplevelBound!-name op))] (error 'check-toplevel-bound! "Unbound identifier ~s"
(CheckToplevelBound!-name op))]
[else [else
m]))] m]))]
[(CheckClosureArity!? op)
(let: ([clos : SlotValue (machine-proc m)])
(cond
[(closure? clos)
(if (= (closure-arity clos)
(CheckClosureArity!-arity op))
m
(error 'check-closure-arity "arity mismatch"))]
[else
(error 'check-closure-arity "not a closure")]))]
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)
(env-push m (env-push m
(make-toplevel (map lookup-primitive (make-toplevel (map lookup-primitive
(ExtendEnvironment/Prefix!-names op))))] (ExtendEnvironment/Prefix!-names op))))]
[(InstallClosureValues!? op) [(InstallClosureValues!? op)
(let: ([a-proc : SlotValue (machine-proc m)]) (let: ([a-proc : SlotValue (machine-proc m)])
(cond (cond
@ -202,6 +216,7 @@
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(target-updater m (make-closure (MakeCompiledProcedure-label op) (target-updater m (make-closure (MakeCompiledProcedure-label op)
(MakeCompiledProcedure-arity op)
(map (lambda: ([r : EnvReference]) (map (lambda: ([r : EnvReference])
(lookup-env-reference m r)) (lookup-env-reference m r))
(MakeCompiledProcedure-closed-vals op))))] (MakeCompiledProcedure-closed-vals op))))]

3
test-compiler.rkt
View File

@ -108,8 +108,11 @@
;; We should see an error here, since the arity is wrong ;; We should see an error here, since the arity is wrong
(test/exn ((lambda (x y z) x) 3)) (test/exn ((lambda (x y z) x) 3))
(test/exn ((lambda (x y z) z) 3))
(test/exn ((lambda (x y z) x) 3 4 5 6)) (test/exn ((lambda (x y z) x) 3 4 5 6))
;; And this should fail because it's not a lambda
(test/exn (not-a-procedure 5))

37
test-simulator.rkt
View File

@ -276,6 +276,7 @@
;; install-closure-values ;; install-closure-values
(let ([m (let ([m
(make-machine (make-undefined) (make-closure 'procedure-entry (make-machine (make-undefined) (make-closure 'procedure-entry
0
(list 1 2 3)) (list 1 2 3))
(list true false) ;; existing environment holds true, false (list true false) ;; existing environment holds true, false
'() '()
@ -291,7 +292,7 @@
;; get-compiled-procedure-entry ;; get-compiled-procedure-entry
(let ([m (let ([m
(make-machine (make-undefined) (make-machine (make-undefined)
(make-closure 'procedure-entry (list 1 2 3)) (make-closure 'procedure-entry 0 (list 1 2 3))
(list true false) ;; existing environment holds true, false (list true false) ;; existing environment holds true, false
'() '()
0 0
@ -303,13 +304,13 @@
;; make-compiled-procedure, with empty closure set ;; make-compiled-procedure, with empty closure set
(let ([m (new-machine `(,(make-AssignPrimOpStatement (let ([m (new-machine `(,(make-AssignPrimOpStatement
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (list))) (make-MakeCompiledProcedure 'procedure-entry 0 (list)))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
procedure-entry procedure-entry
end end
))]) ))])
(test (machine-val (run m)) (test (machine-val (run m))
(make-closure 'procedure-entry (list)))) (make-closure 'procedure-entry 0 (list))))
;; make-compiled-procedure: Capturing a few variables. ;; make-compiled-procedure: Capturing a few variables.
(let ([m (new-machine `(,(make-PushEnvironment 3) (let ([m (new-machine `(,(make-PushEnvironment 3)
@ -318,14 +319,16 @@
,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const 'moe)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const 'moe))
,(make-AssignPrimOpStatement ,(make-AssignPrimOpStatement
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (list (make-EnvLexicalReference 0) (make-MakeCompiledProcedure 'procedure-entry
(make-EnvLexicalReference 2)))) 0
(list (make-EnvLexicalReference 0)
(make-EnvLexicalReference 2))))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
procedure-entry procedure-entry
end end
))]) ))])
(test (machine-val (run m)) (test (machine-val (run m))
(make-closure 'procedure-entry (list 'larry 'moe)))) (make-closure 'procedure-entry 0 (list 'larry 'moe))))
;; make-compiled-procedure: Capturing a toplevel. ;; make-compiled-procedure: Capturing a toplevel.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
@ -337,13 +340,15 @@
,(make-PerformStatement (make-SetToplevel! 0 2 'z)) ,(make-PerformStatement (make-SetToplevel! 0 2 'z))
,(make-AssignPrimOpStatement ,(make-AssignPrimOpStatement
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (list (make-EnvWholePrefixReference 0)))) (make-MakeCompiledProcedure 'procedure-entry
0
(list (make-EnvWholePrefixReference 0))))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
procedure-entry procedure-entry
end end
))]) ))])
(test (machine-val (run m)) (test (machine-val (run m))
(make-closure 'procedure-entry (list (make-toplevel (list "x" "y" "z")))))) (make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z"))))))
;; make-compiled-procedure: Capturing both a toplevel and some lexical values ;; make-compiled-procedure: Capturing both a toplevel and some lexical values
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
@ -360,18 +365,22 @@
,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const 'moe)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const 'moe))
,(make-AssignPrimOpStatement ,(make-AssignPrimOpStatement
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (list (make-EnvWholePrefixReference 3) (make-MakeCompiledProcedure 'procedure-entry
(make-EnvLexicalReference 0) 0
(make-EnvLexicalReference 2)))) (list (make-EnvWholePrefixReference 3)
(make-EnvLexicalReference 0)
(make-EnvLexicalReference 2))))
,(make-PopEnvironment 3 0) ,(make-PopEnvironment 3 0)
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
procedure-entry procedure-entry
end end
))]) ))])
(test (machine-val (run m)) (test (machine-val (run m))
(make-closure 'procedure-entry (list (make-toplevel (list "x" "y" "z")) (make-closure 'procedure-entry
'larry 0
'moe)))) (list (make-toplevel (list "x" "y" "z"))
'larry
'moe))))
;; Test toplevel lookup ;; Test toplevel lookup