diff --git a/NOTES b/NOTES index 7e0f27d..5395809 100644 --- a/NOTES +++ b/NOTES @@ -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. \ No newline at end of file diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt index d197d53..a7a306d 100644 --- a/assemble-helpers.rkt +++ b/assemble-helpers.rkt @@ -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) diff --git a/assemble.rkt b/assemble.rkt index ed441a7..8e331c9 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -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)) diff --git a/collect-jump-targets.rkt b/collect-jump-targets.rkt index 3f17917..293002f 100644 --- a/collect-jump-targets.rkt +++ b/collect-jump-targets.rkt @@ -96,6 +96,10 @@ empty] [(ModuleEntry? an-input) empty] + [(IsModuleInvoked? an-input) + empty] + [(IsModuleLinked? an-input) + empty] [(VariableReference? an-input) empty])) diff --git a/compiler.rkt b/compiler.rkt index 94df4e2..afba65f 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -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-instruction-sequence + `(,(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)) diff --git a/il-structs.rkt b/il-structs.rkt index 3680c5d..0f1eb0f 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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) diff --git a/optimize-il.rkt b/optimize-il.rkt index 3d8381b..491a06c 100644 --- a/optimize-il.rkt +++ b/optimize-il.rkt @@ -141,6 +141,10 @@ oparg] [(ModuleEntry? oparg) oparg] + [(IsModuleInvoked? oparg) + oparg] + [(IsModuleLinked? oparg) + oparg] [(VariableReference? oparg) (let ([t (VariableReference-toplevel oparg)]) (make-VariableReference diff --git a/simulator.rkt b/simulator.rkt index 206ba4f..8b4dc17 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)))