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

more of module invoke

Browse Source
This commit is contained in:
Danny Yoo 2011-05-13 00:57:45 -04:00
parent d0b6d2e8c6
commit 202061fa4a
8 changed files with 204 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
NOTES
View File

@ -468,3 +468,31 @@ the prompt splicing.
----------------------------------------------------------------------
May 13,
begin0 is still broken; I'm a bit unsatisfied with the way that it's
coded, and I know it's not correct yet.
The other thing that's I'm sure needs to be looked at again are the
implementation of prompts.
modules are almost in place. Needs a mechanism for loading modules on
the fly on the network, as well as some kind of predicable namespacing
mechanism. I think the compiler will need to include something like a
(current-module-name-canonizer)
which takes module names (symbol, path-string) and systematically
translates them to predictable identifiers. Anything refering to a
collection should be translated to
collects/...
Anything outside that should be given a name relative to some root.
One should be able to say:
root the translation at "/home/dyoo/work/js-sicp-5.5/examples"
where all translated paths are either from collections, or reachable
from the root. That way, we get predictable paths.

16
assemble-helpers.rkt
View File

@ -56,6 +56,10 @@
(assemble-primitive-kernel-value v)]
[(ModuleEntry? v)
(assemble-module-entry v)]
[(IsModuleInvoked? v)
(assemble-is-module-invoked v)]
[(IsModuleLinked? v)
(assemble-is-module-linked v)]
[(VariableReference? v)
(assemble-variable-reference v)]))
@ -278,6 +282,18 @@
(symbol->string (ModuleName-name (ModuleEntry-name entry)))))
(: assemble-is-module-invoked (IsModuleInvoked -> String))
(define (assemble-is-module-invoked entry)
(format "MACHINE.modules[~s].label"
(symbol->string (ModuleName-name (IsModuleInvoked-name entry)))))
(: assemble-is-module-linked (IsModuleLinked -> String))
(define (assemble-is-module-linked entry)
(format "(MACHINE.modules[~s] !== undefined)"
(symbol->string (ModuleName-name (IsModuleLinked-name entry)))))
(: assemble-variable-reference (VariableReference -> String))
(define (assemble-variable-reference varref)

4
assemble.rkt
View File

@ -204,6 +204,10 @@ EOF
(format "if (~a === false) { ~a }"
(assemble-oparg (TestFalse-operand test))
jump)]
[(TestTrue? test)
(format "if (~a !== false) { ~a }"
(assemble-oparg (TestTrue-operand test))
jump)]
[(TestOne? test)
(format "if (~a === 1) { ~a }"
(assemble-oparg (TestOne-operand test))

4
collect-jump-targets.rkt
View File

@ -96,6 +96,10 @@
empty]
[(ModuleEntry? an-input)
empty]
[(IsModuleInvoked? an-input)
empty]
[(IsModuleLinked? an-input)
empty]
[(VariableReference? an-input)
empty]))

148
compiler.rkt
View File

@ -165,6 +165,50 @@
(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
;; Add linkage for expressions.
(define (end-with-linkage linkage cenv instruction-sequence)
(append-instruction-sequences instruction-sequence
(compile-linkage cenv linkage)))
(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
;; Generates the code necessary to drive the rest of the computation (represented as the linkage).
(define (compile-linkage cenv linkage)
(cond
[(ReturnLinkage? linkage)
(cond
[(ReturnLinkage-tail? linkage)
;; Under tail calls, clear the environment of the current stack frame (represented by cenv)
;; and do the jump.
(make-instruction-sequence
`(,(make-PopEnvironment (make-Const (length cenv))
(make-Const 0))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[else
;; Under non-tail calls, leave the stack as is and just do the jump.
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))])]
[(NextLinkage? linkage)
empty-instruction-sequence]
[(LabelLinkage? linkage)
(make-instruction-sequence
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; The main dispatching function for compilation.
;; Compiles an expression into an instruction sequence.
@ -256,66 +300,82 @@
(: compile-module (Module CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Generates code to write out the top prefix, evaluate the rest of the body,
;; and then pop the top prefix off.
(define (compile-module top cenv target linkage)
(define (compile-module mod cenv target linkage)
;; fixme: this is not right yet. This should instead install a module record
;; that has not yet been invoked.
;; fixme: This also needs to generate code for the requires and provides.
(let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))
(Prefix-names (Module-prefix top))])
(let*: ([after-module-body (make-label 'afterModuleBody)]
[module-entry (make-label 'module-entry)]
[names : (Listof (U False Symbol GlobalBucket ModuleVariable))
(Prefix-names (Module-prefix mod))]
[module-cenv : CompileTimeEnvironment (list (Module-prefix mod))])
(end-with-linkage
linkage cenv
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Module-code top)
(cons (Module-prefix top) cenv)
`(,(make-GotoStatement (make-Label after-module-body))))
;; Module body definition
(apply append-instruction-sequences
(map compile-module-invoke (Module-requires mod)))
(make-instruction-sequence
`(,module-entry
,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
;; TODO: we need to sequester the prefix of the module with the record.
(compile (Module-code mod)
(cons (Module-prefix mod) module-cenv)
target
next-linkage/drop-multiple)
;; Cleanup
(make-instruction-sequence
`(,(make-PopEnvironment (make-Const 1)
(make-Const 0))))))))
(make-Const 0))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))
after-module-body))))
(: compile-module-invoke (ModuleName -> InstructionSequence))
;; Generates code that will invoke a module (if it hasn't been invoked yet)
;; FIXME: assumes the module has already been linked. We should error out
;; if the module hasn't been linked yet.
(define (compile-module-invoke a-module-name)
(let* ([linked (make-label 'linked)]
[already-loaded (make-label 'alreadyLoaded)]
[on-return-multiple (make-label 'onReturnMultiple)]
[on-return (make-LinkedLabel (make-label 'onReturn)
on-return-multiple)])
(make-instruction-sequence
`(,(make-TestAndBranchStatement (make-TestTrue
(make-IsModuleLinked a-module-name))
linked)
;; TODO: raise an exception here that says that the module hasn't been
;; linked yet.
,(make-DebugPrint (make-Const
(format "DEBUG: the module ~a hasn't been linked in yet!"
(ModuleName-name a-module-name))))
,linked
,(make-TestAndBranchStatement (make-TestTrue
(make-IsModuleInvoked a-module-name))
already-loaded)
,(make-PushControlFrame/Call on-return)
,(make-GotoStatement (make-ModuleEntry a-module-name))
,on-return-multiple
,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount)
(make-Const 1))
(make-Const 0))
,on-return
,already-loaded))))
(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
;; Add linkage for expressions.
(define (end-with-linkage linkage cenv instruction-sequence)
(append-instruction-sequences instruction-sequence
(compile-linkage cenv linkage)))
(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
;; Generates the code necessary to drive the rest of the computation (represented as the linkage).
(define (compile-linkage cenv linkage)
(cond
[(ReturnLinkage? linkage)
(cond
[(ReturnLinkage-tail? linkage)
;; Under tail calls, clear the environment of the current stack frame (represented by cenv)
;; and do the jump.
(make-instruction-sequence
`(,(make-PopEnvironment (make-Const (length cenv))
(make-Const 0))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[else
;; Under non-tail calls, leave the stack as is and just do the jump.
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))])]
[(NextLinkage? linkage)
empty-instruction-sequence]
[(LabelLinkage? linkage)
(make-instruction-sequence
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: emit-singular-context (Linkage -> InstructionSequence))

16
il-structs.rkt
View File

@ -34,6 +34,8 @@
CompiledProcedureEntry
CompiledProcedureClosureReference
ModuleEntry
IsModuleInvoked
IsModuleLinked
PrimitiveKernelValue
VariableReference))
@ -89,14 +91,22 @@
#:transparent)
(define-struct: PrimitivesReference ([name : Symbol])
#:transparent)
;; Produces the entry point of the module.
(define-struct: ModuleEntry ([name : ModuleName])
#:transparent)
;; Produces true if the module has already been invoked
(define-struct: IsModuleInvoked ([name : ModuleName])
#:transparent)
;; Produces true if the module has been loaded into the machine
(define-struct: IsModuleLinked ([name : ModuleName])
#:transparent)
@ -288,12 +298,14 @@
;; Primitive tests (used with TestAndBranch)
(define-type PrimitiveTest (U
TestFalse
TestTrue
TestOne
TestZero
TestPrimitiveProcedure
TestClosureArityMismatch
))
(define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestTrue ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)

4
optimize-il.rkt
View File

@ -141,6 +141,10 @@
oparg]
[(ModuleEntry? oparg)
oparg]
[(IsModuleInvoked? oparg)
oparg]
[(IsModuleLinked? oparg)
oparg]
[(VariableReference? oparg)
(let ([t (VariableReference-toplevel oparg)])
(make-VariableReference

48
simulator.rkt
View File

@ -207,25 +207,26 @@
(: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
(define (step-test-and-branch! m stmt)
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
(if (let: ([v : Boolean (cond
[(TestFalse? test)
(not (evaluate-oparg m (TestFalse-operand test)))]
[(TestOne? test)
(= (ensure-natural (evaluate-oparg m (TestOne-operand test)))
1)]
[(TestZero? test)
(= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
0)]
[(TestPrimitiveProcedure? test)
(primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))]
[(TestClosureArityMismatch? test)
(let ([proc (ensure-closure
(evaluate-oparg m (TestClosureArityMismatch-closure test)))]
[n (ensure-natural
(evaluate-oparg m (TestClosureArityMismatch-n test)))])
(not (arity-match? (closure-arity proc) n)))])])
v)
(if (ann (cond
[(TestFalse? test)
(not (evaluate-oparg m (TestFalse-operand test)))]
[(TestTrue? test)
(and (evaluate-oparg m (TestTrue-operand test)) #t)]
[(TestOne? test)
(= (ensure-natural (evaluate-oparg m (TestOne-operand test)))
1)]
[(TestZero? test)
(= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
0)]
[(TestPrimitiveProcedure? test)
(primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))]
[(TestClosureArityMismatch? test)
(let ([proc (ensure-closure
(evaluate-oparg m (TestClosureArityMismatch-closure test)))]
[n (ensure-natural
(evaluate-oparg m (TestClosureArityMismatch-n test)))])
(not (arity-match? (closure-arity proc) n)))])
Boolean)
(jump! m (TestAndBranchStatement-label stmt))
'ok)))
@ -792,6 +793,15 @@
(ModuleName-name (ModuleEntry-name an-oparg)))])
(module-record-label a-module))]
[(IsModuleInvoked? an-oparg)
(let ([a-module (hash-ref (machine-modules m)
(ModuleName-name (IsModuleInvoked-name an-oparg)))])
(module-record-invoked? a-module))]
[(IsModuleLinked? an-oparg)
(hash-has-key? (machine-modules m)
(ModuleName-name (IsModuleLinked-name an-oparg)))]
[(VariableReference? an-oparg)
(let ([t (VariableReference-toplevel an-oparg)])
(make-ToplevelReference (ensure-toplevel (env-ref m (ToplevelRef-depth t)))