diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 61a3c79..0f49228 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -960,12 +960,7 @@ (default)]))] [(ModuleVariable? op-knowledge) (cond - [(or (symbol=? (ModuleLocator-name - (ModuleVariable-module-name op-knowledge)) - '#%kernel) - (symbol=? (ModuleLocator-name - (ModuleVariable-module-name op-knowledge)) - 'whalesong/lang/kernel.rkt)) + [(kernel-module-locator? (ModuleVariable-module-name op-knowledge)) (let ([op (ModuleVariable-name op-knowledge)]) (cond [(KernelPrimitiveName/Inline? op) (compile-open-codeable-application op exp cenv target linkage)] @@ -984,6 +979,21 @@ (make-RaiseOperatorApplicationError! (make-Reg 'proc))))])))) + +(: kernel-module-locator? (ModuleLocator -> Boolean)) +;; Produces true if the ModuleLocator is pointing to a module that's marked +;; as kernel. +(define (kernel-module-locator? a-module-locator) + (or (symbol=? (ModuleLocator-name + a-module-locator) + '#%kernel) + (symbol=? (ModuleLocator-name + a-module-locator) + 'whalesong/lang/kernel.rkt))) + + + + (: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-general-application exp cenv target linkage) (let* ([extended-cenv @@ -1423,38 +1433,37 @@ linkage cenv (append-instruction-sequences - ;; (make-TestAndJumpStatement (make-TestPrimitiveProcedure - ;; (make-Reg 'proc)) - ;; primitive-branch) - - - ;; Compiled branch (make-PerformStatement (make-CheckClosureAndArity!)) (compile-compiled-procedure-application cenv number-of-arguments 'dynamic target compiled-linkage) - - ;; Primitive branch - ;; primitive-branch - ;; (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) - ;; (compile-primitive-application cenv target primitive-linkage) after-call))))) +;; If we know the procedure is implemented as a primitive (as opposed to a general closure), +;; we can do a little less work. +;; Assumes 1. the procedure value is loaded into proc, +;; 2. number-of-arguments has been written into the argcount register, +; ; 3. the number-of-arguments values are on the stack. +(: compile-primitive-procedure-call (CompileTimeEnvironment OpArg Target Linkage + -> InstructionSequence)) +(define (compile-primitive-procedure-call cenv number-of-arguments target linkage) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-PerformStatement (make-CheckPrimitiveArity!)) + (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) + (make-PopEnvironment number-of-arguments (make-Const 0)) + (if (eq? target 'val) + empty-instruction-sequence + (make-AssignImmediateStatement target (make-Reg 'val))) + (emit-singular-context linkage)))) + + -;; (: compile-primitive-application (CompileTimeEnvironment Target Linkage -> InstructionSequence)) -;; (define (compile-primitive-application cenv target linkage) -;; (let ([singular-context-check (emit-singular-context linkage)]) -;; (append-instruction-sequences -;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) -;; (make-PopEnvironment (make-Reg 'argcount) -;; (make-Const 0)) -;; (if (eq? target 'val) -;; empty-instruction-sequence -;; (make-AssignImmediateStatement target (make-Reg 'val))) -;; singular-context-check))) diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index 3ac98ed..8c17162 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -287,7 +287,9 @@ CaptureEnvironment CaptureControl - CallKernelPrimitiveProcedure)) + CallKernelPrimitiveProcedure + ApplyPrimitiveProcedure + )) ;; Gets the label from the closure stored in the 'proc register and returns it. (define-struct: GetCompiledProcedureEntry () @@ -323,6 +325,9 @@ #:transparent) +(define-struct: ApplyPrimitiveProcedure () #:transparent) + + (define-struct: MakeBoxedEnvironmentValue ([depth : Natural]) @@ -368,6 +373,10 @@ (define-struct: CheckClosureAndArity! () #:transparent) +;; Check the primitive can accept the right arguments +;; (stored as a number in the argcount register.). +(define-struct: CheckPrimitiveArity! () #:transparent) + ;; Extends the environment with a prefix that holds ;; lookups to the namespace. @@ -467,6 +476,7 @@ (define-type PrimitiveCommand (U CheckToplevelBound! CheckClosureAndArity! + CheckPrimitiveArity! ExtendEnvironment/Prefix! InstallClosureValues! diff --git a/compiler/optimize-il.rkt b/compiler/optimize-il.rkt index 379b915..194afa0 100644 --- a/compiler/optimize-il.rkt +++ b/compiler/optimize-il.rkt @@ -139,6 +139,9 @@ op] [(CallKernelPrimitiveProcedure? op) + op] + + [(ApplyPrimitiveProcedure? op) op])) diff --git a/js-assembler/assemble-expression.rkt b/js-assembler/assemble-expression.rkt index 9c15358..1b8d82e 100644 --- a/js-assembler/assemble-expression.rkt +++ b/js-assembler/assemble-expression.rkt @@ -58,4 +58,6 @@ (add1 (MakeBoxedEnvironmentValue-depth op)))] [(CallKernelPrimitiveProcedure? op) - (open-code-kernel-primitive-procedure op blockht)])) \ No newline at end of file + (open-code-kernel-primitive-procedure op blockht)] + [(ApplyPrimitiveProcedure? op) + "M.p.rawImpl(M)"])) \ No newline at end of file diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index 1b1eda0..0b754e9 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -24,6 +24,9 @@ [(CheckClosureAndArity!? op) "RT.checkClosureAndArity(M);"] + + [(CheckPrimitiveArity!? op) + "RT.checkPrimitiveArity(M);"] [(ExtendEnvironment/Prefix!? op) (let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names op)]) diff --git a/js-assembler/collect-jump-targets.rkt b/js-assembler/collect-jump-targets.rkt index 0f334bf..bd5a264 100644 --- a/js-assembler/collect-jump-targets.rkt +++ b/js-assembler/collect-jump-targets.rkt @@ -112,8 +112,8 @@ (list (MakeCompiledProcedure-label op))] [(MakeCompiledProcedureShell? op) (list (MakeCompiledProcedureShell-label op))] - ;; [(ApplyPrimitiveProcedure? op) - ;; empty] + [(ApplyPrimitiveProcedure? op) + empty] [(CaptureEnvironment? op) empty] [(CaptureControl? op) @@ -122,6 +122,7 @@ empty] [(CallKernelPrimitiveProcedure? op) empty])) + (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol))) (define (collect-primitive-command op) @@ -258,8 +259,8 @@ (list (MakeCompiledProcedure-label op))] [(MakeCompiledProcedureShell? op) (list (MakeCompiledProcedureShell-label op))] - ;; [(ApplyPrimitiveProcedure? op) - ;; empty] + [(ApplyPrimitiveProcedure? op) + empty] [(CaptureEnvironment? op) empty] [(CaptureControl? op) diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 900853c..2c310b8 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -691,6 +691,11 @@ } }; + var checkPrimitiveArity = function(M) { + if(!isArityMatching(M.p.racketArity,M.a)) { + raiseArityMismatchError(M,M.p,M.a); + } + }; ////////////////////////////////////////////////////////////////////// @@ -842,6 +847,6 @@ exports['si_context_expected'] = si_context_expected; exports['si_context_expected_1'] = si_context_expected_1; exports['checkClosureAndArity'] = checkClosureAndArity; - + exports['checkPrimitiveArity'] = checkPrimitiveArity; }(this.plt, this.plt.baselib)); \ No newline at end of file diff --git a/simulator/simulator-helpers.rkt b/simulator/simulator-helpers.rkt deleted file mode 100644 index 3e8b148..0000000 --- a/simulator/simulator-helpers.rkt +++ /dev/null @@ -1,117 +0,0 @@ -#lang racket/base - -(require "simulator-structs.rkt") -(provide ensure-primitive-value-box - ensure-primitive-value - ensure-list - PrimitiveValue->racket - racket->PrimitiveValue) -(define (ensure-primitive-value-box x) - (if (and (box? x) - (PrimitiveValue? (unbox x))) - x - (error 'ensure-primitive-value-box "~s" x))) - - - -;; Make sure the value is primitive. -(define (ensure-primitive-value val) - (let loop ([v val]) - (cond - [(string? v) - v] - [(symbol? v) - v] - [(number? v) - v] - [(boolean? v) - v] - [(null? v) - v] - [(VoidValue? v) - v] - [(MutablePair? v) - v] - [(primitive-proc? v) - v] - [(closure? v) - v] - [(undefined? v) - v] - [(vector? v) - v] - [(ContinuationMarkSet? v) - v] - [else - (error 'ensure-primitive-value "~s" v)]))) - - -(define (ensure-list v) - (cond - [(null? v) - v] - [(and (MutablePair? v) - (PrimitiveValue? (MutablePair-h v)) - (PrimitiveValue? (MutablePair-t v))) - v] - [else - (error 'ensure-list)])) - - -(define (PrimitiveValue->racket v) - (cond - [(string? v) - v] - [(number? v) - v] - [(symbol? v) - v] - [(boolean? v) - v] - [(null? v) - v] - [(VoidValue? v) - (void)] - [(undefined? v) - (letrec ([x x]) x)] - [(primitive-proc? v) - v] - [(closure? v) - v] - [(vector? v) - (apply vector (map PrimitiveValue->racket (vector->list v)))] - [(MutablePair? v) - (cons (PrimitiveValue->racket (MutablePair-h v)) - (PrimitiveValue->racket (MutablePair-t v)))] - [(ContinuationMarkSet? v) - v])) - - -(define (racket->PrimitiveValue v) - (cond - [(string? v) - v] - [(number? v) - v] - [(symbol? v) - v] - [(boolean? v) - v] - [(null? v) - v] - [(void? v) - the-void-value] - [(eq? v (letrec ([x x]) x)) - (make-undefined)] - [(procedure? v) - (error 'racket->PrimitiveValue "Can't coerse procedure")] - [(primitive-proc? v) - v] - [(closure? v) - v] - [(vector? v) - (apply vector (map racket->PrimitiveValue (vector->list v)))] - [(pair? v) - (make-MutablePair (racket->PrimitiveValue (car v)) - (racket->PrimitiveValue (cdr v)))])) - diff --git a/simulator/simulator-primitives.rkt b/simulator/simulator-primitives.rkt deleted file mode 100644 index 16bd544..0000000 --- a/simulator/simulator-primitives.rkt +++ /dev/null @@ -1,278 +0,0 @@ -#lang racket/base -(require "simulator-structs.rkt" - "simulator-helpers.rkt" - "../compiler/il-structs.rkt" - "../compiler/arity-structs.rkt" - racket/math - racket/list - (for-syntax racket/base)) - -(provide lookup-primitive set-primitive!) - -(define mutated-primitives (make-hasheq)) -(define (set-primitive! n p) - (hash-set! mutated-primitives n p)) - - -(define (extract-arity proc) - (let loop ([racket-arity (procedure-arity proc)]) - (cond - [(number? racket-arity) - racket-arity] - [(arity-at-least? racket-arity) - (make-ArityAtLeast (arity-at-least-value racket-arity))] - [(list? racket-arity) - (map loop racket-arity)]))) - - - - -(define-syntax (make-lookup stx) - (syntax-case stx () - [(_ #:functions (name ...) - #:constants (cname ...)) - (with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))] - [((name exported-name) ...) - (map (lambda (name) - (syntax-case name () - [(real-name exported-name) - (list #'real-name #'exported-name)] - [_ - (identifier? name) - (list name name)])) - (syntax->list #'(name ...)))]) - (syntax/loc stx - (let ([prim-name (make-primitive-proc - (lambda (machine . args) - (apply name args)) - (extract-arity name) - 'exported-name)] - ...) - (lambda (n) - (cond - [(hash-has-key? mutated-primitives n) - (hash-ref mutated-primitives n)] - [(eq? n 'exported-name) - prim-name] - ... - [(eq? n 'cname) - cname] - ... - [else - (make-undefined)] - )))))])) - -(define e (exp 1)) - -(define my-cons (lambda (x y) - (make-MutablePair x y))) - -(define my-list (lambda args - (let loop ([args args]) - (cond - [(null? args) - null] - [else - (make-MutablePair (car args) - (loop (cdr args)))])))) -(define my-car (lambda (x) - (MutablePair-h x))) - -(define my-cdr (lambda (x) - (MutablePair-t x))) - - -(define my-cadr (lambda (x) - (MutablePair-h (MutablePair-t x)))) - -(define my-caddr (lambda (x) - (MutablePair-h (MutablePair-t (MutablePair-t x))))) - - -(define my-pair? (lambda (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) - the-void-value)) - -(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) - the-void-value)) - -(define my-set-cdr! (lambda (p v) - (set-MutablePair-t! p v) - the-void-value)) - -(define my-void (lambda args - the-void-value)) - -(define my-display (lambda args - (apply display args) - the-void-value)) - -(define my-displayln (lambda args - (apply displayln args) - the-void-value)) - -(define my-newline (lambda args - (apply newline args) - the-void-value)) - -(define my-vector-set! (lambda args - (apply vector-set! args) - the-void-value)) - - - -(define my-member (lambda (x l) - (let loop ([l l]) - (cond - [(null? l) - #f] - [(MutablePair? l) - (cond - [(equal? x (MutablePair-h l)) - l] - [else - (loop (MutablePair-t l))])] - [else - (error 'member "not a list: ~s" l)])))) - -(define my-reverse (lambda (l) - (let loop ([l l] - [acc null]) - (cond - [(null? l) - acc] - [(MutablePair? l) - (loop (MutablePair-t l) - (make-MutablePair (MutablePair-h l) acc))] - [else - (error 'member "not a list: ~s" l)])))) - - -(define my-printf (lambda (fmt args) - (apply printf fmt (map (lambda (x) - (PrimitiveValue->racket x)) - args)))) - - - -(define current-continuation-marks - (letrec ([f (case-lambda [(a-machine) - (f a-machine default-continuation-prompt-tag-value)] - [(a-machine tag) - (make-ContinuationMarkSet - (let loop ([frames (machine-control a-machine)]) - (cond - [(empty? frames) - empty] - [else - (append (hash-map (frame-marks (first frames)) - cons) - (if (eq? tag (frame-tag (first frames))) - empty - (loop (rest frames))))])))])]) - (make-primitive-proc (lambda (machine . args) (apply f machine args)) - '(0 1) - 'current-continuation-marks))) - - -(define continuation-mark-set->list - ;; not quite correct: ContinuationMarkSets need to preserve frame structure a bit more. - ;; At the very least, we need to keep track of prompt tags somewhere. - (let ([f (lambda (a-machine mark-set key) - (let ([marks (ContinuationMarkSet-marks mark-set)]) - (foldr make-MutablePair - null - (map cdr (filter (lambda (k+v) - (eq? (car k+v) key)) - marks)))))]) - (make-primitive-proc (lambda (machine . args) (apply f machine args)) - '2 ;; fixme: should deal with prompt tags too - 'current-continuation-marks))) - - - - - -(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= - sub1 - not - null? - eq? - add1 - sub1 - zero? - abs - (my-void void) - quotient - remainder - - (my-display display) - (my-displayln displayln) - (my-newline newline) - - symbol->string - string-append - string-length - - (my-cons cons) - (my-list list) - (my-car car) - (my-cdr cdr) - (my-cadr cadr) - (my-caddr caddr) - (my-pair? pair?) - null? - (my-set-car! set-car!) - (my-set-cdr! set-cdr!) - (my-member member) - (my-reverse reverse) - - - (my-box box) - (my-unbox unbox) - (my-set-box! set-box!) - - vector - (my-vector-set! vector-set!) - vector-ref - (my-vector->list vector->list) - (my-list->vector list->vector) - vector-length - make-vector - - - equal? - symbol? - - - (my-printf printf) - ) - #:constants (null pi e - current-continuation-marks - continuation-mark-set->list))) - - diff --git a/simulator/simulator-structs.rkt b/simulator/simulator-structs.rkt deleted file mode 100644 index 752e9fc..0000000 --- a/simulator/simulator-structs.rkt +++ /dev/null @@ -1,203 +0,0 @@ -#lang typed/racket/base - -(provide (all-defined-out)) - -(require "../compiler/arity-structs.rkt" - "../compiler/il-structs.rkt" - "../compiler/expression-structs.rkt" - "../compiler/lexical-structs.rkt") - - - - -;; A special "label" in the system that causes evaluation to stop. -(define-struct: halt ()) -(define HALT (make-halt)) - - - -(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean - Null VoidValue - undefined - - primitive-proc - closure - - (Vectorof PrimitiveValue) - MutablePair - - ContinuationMarkSet - - ToplevelReference - ))) -(define-type SlotValue (U PrimitiveValue - (Boxof PrimitiveValue) - toplevel - CapturedControl - CapturedEnvironment)) - - -(define-struct: VoidValue () #:transparent) -(define the-void-value (make-VoidValue)) - - -(define-struct: MutablePair ([h : PrimitiveValue] - [t : PrimitiveValue]) - #:mutable #:transparent) - -;; For continuation capture: -(define-struct: CapturedControl ([frames : (Listof frame)])) -(define-struct: CapturedEnvironment ([vals : (Listof SlotValue)])) - - -(define-struct: machine ([val : SlotValue] - [proc : SlotValue] - [argcount : SlotValue] - [env : (Listof SlotValue)] - [control : (Listof frame)] - - [pc : Natural] ;; program counter - [text : (Vectorof Statement)] ;; text of the program - - [modules : (HashTable Symbol module-record)] - - ;; other metrics for debugging - [stack-size : Natural] - - ;; compute position from label - [jump-table : (HashTable Symbol Natural)] - ) - #:transparent - #:mutable) - - -(define-struct: module-record ([name : Symbol] - [self-path : Symbol] - [label : Symbol] - [invoked? : Boolean] - [namespace : (HashTable Symbol PrimitiveValue)] - [toplevel : (U False toplevel)]) - #:transparent - #:mutable) - - -(define-type frame (U GenericFrame CallFrame PromptFrame)) - - -(define-struct: GenericFrame ([temps : (HashTable Symbol PrimitiveValue)] - [marks : (HashTable PrimitiveValue PrimitiveValue)]) - #:transparent) - - -(define-struct: CallFrame ([return : (U LinkedLabel halt)] - ;; The procedure being called. Used to optimize self-application - [proc : (U closure #f)] - ;; TODO: add continuation marks - [temps : (HashTable Symbol PrimitiveValue)] - [marks : (HashTable PrimitiveValue PrimitiveValue)]) - #:transparent - #:mutable) ;; mutable because we want to allow mutation of proc. - -(define-struct: PromptFrame ([tag : ContinuationPromptTagValue] - [return : (U LinkedLabel halt)] - [env-depth : Natural] - [temps : (HashTable Symbol PrimitiveValue)] - [marks : (HashTable PrimitiveValue PrimitiveValue)]) - #:transparent) - - -(: frame-temps (frame -> (HashTable Symbol PrimitiveValue))) -(define (frame-temps a-frame) - (cond - [(GenericFrame? a-frame) - (GenericFrame-temps a-frame)] - [(CallFrame? a-frame) - (CallFrame-temps a-frame)] - [(PromptFrame? a-frame) - (PromptFrame-temps a-frame)])) - - -(: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue))) -(define (frame-marks a-frame) - (cond - [(GenericFrame? a-frame) - (GenericFrame-marks a-frame)] - [(CallFrame? a-frame) - (CallFrame-marks a-frame)] - [(PromptFrame? a-frame) - (PromptFrame-marks a-frame)])) - - -(: frame-tag (frame -> (U ContinuationPromptTagValue #f))) -(define (frame-tag a-frame) - (cond - [(GenericFrame? a-frame) - #f] - [(CallFrame? a-frame) - #f] - [(PromptFrame? a-frame) - (PromptFrame-tag a-frame)])) - - - -(define-struct: ContinuationPromptTagValue ([name : Symbol]) - #:transparent) - -(define default-continuation-prompt-tag-value - (make-ContinuationPromptTagValue 'default-continuation-prompt)) - - - -(define-struct: ContinuationMarkSet ([marks : (Listof (Pairof PrimitiveValue PrimitiveValue))]) - #:transparent) - - - - - - - -(define-struct: toplevel ([names : (Listof (U #f Symbol GlobalBucket ModuleVariable))] - [vals : (Listof PrimitiveValue)]) - #:transparent - #:mutable) - - - - - -;; Primitive procedure wrapper -(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)] - [arity : Arity] - [display-name : (U Symbol LamPositionalName)]) - #:transparent) - - - - -;; Compiled procedure closures -(define-struct: closure ([label : Symbol] - [arity : Arity] - [vals : (Listof SlotValue)] - [display-name : (U Symbol LamPositionalName)]) - #:transparent - #:mutable) - - - - -(define-struct: ToplevelReference ([toplevel : toplevel] - [pos : Natural]) - #:transparent) - - -;; undefined value -(define-struct: undefined () - #:transparent) - - - -(define-predicate PrimitiveValue? PrimitiveValue) -(define-predicate frame? frame) - - diff --git a/simulator/simulator.rkt b/simulator/simulator.rkt deleted file mode 100644 index 36d60bc..0000000 --- a/simulator/simulator.rkt +++ /dev/null @@ -1,1163 +0,0 @@ -#lang typed/racket/base - -;; An evaluator for the intermediate language, so I can do experiments. -;; -;; For example, I'll need to be able to count the number of statements executed by an evaluation. -;; I also need to do things like count pushes and pops. Basically, low-level benchmarking. - -(require "simulator-structs.rkt" - "../compiler/expression-structs.rkt" - "../compiler/il-structs.rkt" - "../compiler/lexical-structs.rkt" - "../compiler/arity-structs.rkt" - "../compiler/bootstrapped-primitives.rkt" - "../compiler/kernel-primitives.rkt" - racket/list - racket/match - (for-syntax racket/base)) - -(require/typed "simulator-primitives.rkt" - [lookup-primitive (Symbol -> PrimitiveValue)] - [set-primitive! (Symbol PrimitiveValue -> Void)]) - -(require/typed "simulator-helpers.rkt" - [ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))] - [ensure-primitive-value (SlotValue -> PrimitiveValue)] - [ensure-list (Any -> (U Null MutablePair))] - [racket->PrimitiveValue (Any -> PrimitiveValue)]) - - -(provide new-machine - can-step? - step! - current-instruction - current-simulated-output-port - machine-control-size - invoke-module-as-main) - - -(define current-simulated-output-port (make-parameter (current-output-port))) - - - -(define end-of-program-text 'end-of-program-text) - - -(: new-machine (case-lambda [(Listof Statement) -> machine] - [(Listof Statement) Boolean -> machine])) -(define new-machine - (case-lambda: - [([program-text : (Listof Statement)]) - (new-machine program-text #f)] - [([program-text : (Listof Statement)] - [with-bootstrapping-code? : Boolean]) - (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)] - [program-text : (Listof Statement) - (append (cond [with-bootstrapping-code? - (append (get-bootstrapping-code) - program-text)] - [else - program-text]) - (list end-of-program-text))]) - (let: ([m : machine (make-machine (make-undefined) - (make-undefined) - (make-undefined) - '() - '() - 0 - (list->vector program-text) - ((inst make-hash Symbol module-record)) - 0 - ((inst make-hash Symbol Natural)))]) - (let: loop : Void ([i : Natural 0]) - (when (< i (vector-length (machine-text m))) - (let: ([stmt : Statement (vector-ref (machine-text m) i)]) - (when (symbol? stmt) - (hash-set! (machine-jump-table m) stmt i)) - (when (LinkedLabel? stmt) - (hash-set! (machine-jump-table m) (LinkedLabel-label stmt) i)) - (loop (add1 i))))) - m))])) - - - -(: machine-control-size (machine -> Natural)) -(define (machine-control-size m) - (length (machine-control m))) - - - - - -(: invoke-module-as-main (machine Symbol -> 'ok)) -;; Assuming the module has been loaded in, sets the machine -;; up to invoke its body. -(define (invoke-module-as-main m module-name) - (let ([frame (make-PromptFrame - default-continuation-prompt-tag-value - HALT - (length (machine-env m)) - (make-hasheq) - (make-hasheq))] - [module-record (hash-ref (machine-modules m) module-name)]) - (control-push! m frame) - (jump! m (module-record-label module-record)))) - - - - - -(: can-step? (machine -> Boolean)) -;; Produces true if we can make a further step in the simulation. -(define (can-step? m) - (< (machine-pc m) - (vector-length (machine-text m)))) - - -(: step! (machine -> 'ok)) -;; Take one simulation step. -(define (step! m) - (let*: ([i : Statement (current-instruction m)] - [result : 'ok - (cond - [(symbol? i) - 'ok] - [(LinkedLabel? i) - 'ok] - [(DebugPrint? i) - ;; Hack to monitor evaluation. - (displayln (evaluate-oparg m (DebugPrint-value i))) - 'ok] - [(AssignImmediateStatement? i) - (step-assign-immediate! m i)] - [(AssignPrimOpStatement? i) - (step-assign-primitive-operation! m i)] - [(PerformStatement? i) - (step-perform! m i)] - [(GotoStatement? i) - (step-goto! m i)] - [(TestAndJumpStatement? i) - (step-test-and-branch! m i)] - [(PopEnvironment? i) - (step-pop-environment! m i)] - [(PushEnvironment? i) - (step-push-environment! m i)] - [(PushImmediateOntoEnvironment? i) - (step-push-immediate-onto-environment! m i)] - [(PushControlFrame/Generic? i) - (step-push-control-frame/generic! m i)] - [(PushControlFrame/Call? i) - (step-push-control-frame! m i)] - [(PushControlFrame/Prompt? i) - (step-push-control-frame/prompt! m i)] - [(PopControlFrame? i) - (step-pop-control-frame! m i)] - [(Comment? i) - 'ok] - )]) - (increment-pc! m))) - - - - -(: step-goto! (machine GotoStatement -> 'ok)) -(define (step-goto! m a-goto) - (let: ([t : Symbol (ensure-symbol (evaluate-oparg m (GotoStatement-target a-goto)))]) - (jump! m t))) - - -(: step-assign-immediate! (machine AssignImmediateStatement -> 'ok)) -(define (step-assign-immediate! m stmt) - (let: ([t : Target (AssignImmediateStatement-target stmt)] - [v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))]) - ((get-target-updater t) m v))) - - -(: step-push-environment! (machine PushEnvironment -> 'ok)) -(define (step-push-environment! m stmt) - (let: loop : 'ok ([n : Natural (PushEnvironment-n stmt)]) - (cond - [(= n 0) - 'ok] - [else - (env-push! m (if (PushEnvironment-unbox? stmt) - (box (make-undefined)) - (make-undefined))) - (loop (sub1 n))]))) - -(: step-pop-environment! (machine PopEnvironment -> 'ok)) -(define (step-pop-environment! m stmt) - (env-pop! m - (ensure-natural (evaluate-oparg m (PopEnvironment-n stmt))) - (ensure-natural (evaluate-oparg m (PopEnvironment-skip stmt))))) - -(: step-push-immediate-onto-environment! (machine PushImmediateOntoEnvironment -> 'ok)) -(define (step-push-immediate-onto-environment! m stmt) - (let ([t (make-EnvLexicalReference 0 (PushImmediateOntoEnvironment-box? stmt))] - [v (evaluate-oparg m (PushImmediateOntoEnvironment-value stmt))]) - (step-push-environment! m (make-PushEnvironment 1 (PushImmediateOntoEnvironment-box? stmt))) - ((get-target-updater t) m v))) - - - -(: step-push-control-frame/generic! (machine PushControlFrame/Generic -> 'ok)) -(define (step-push-control-frame/generic! m stmt) - (control-push! m (make-GenericFrame (make-hasheq) - (make-hasheq)))) - - -(: step-push-control-frame! (machine PushControlFrame/Call -> 'ok)) -(define (step-push-control-frame! m stmt) - (control-push! m (make-CallFrame (PushControlFrame/Call-label stmt) - (ensure-closure-or-false (machine-proc m)) - (make-hasheq) - (make-hasheq)))) - -(: step-push-control-frame/prompt! (machine PushControlFrame/Prompt -> 'ok)) -(define (step-push-control-frame/prompt! m stmt) - (control-push! m (make-PromptFrame - (let ([tag (PushControlFrame/Prompt-tag stmt)]) - (cond - [(DefaultContinuationPromptTag? tag) - default-continuation-prompt-tag-value] - [(OpArg? tag) - (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))])) - (PushControlFrame/Prompt-label stmt) - (length (machine-env m)) - (make-hasheq) - (make-hasheq)))) - - - -(: step-pop-control-frame! (machine (U PopControlFrame) -> 'ok)) -(define (step-pop-control-frame! m stmt) - (let: ([l : Symbol (control-pop! m)]) - 'ok)) - -(: step-test-and-branch! (machine TestAndJumpStatement -> 'ok)) -(define (step-test-and-branch! m stmt) - (let: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]) - (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 (TestAndJumpStatement-label stmt)) - 'ok))) - - -(: lookup-atomic-register (machine AtomicRegisterSymbol -> SlotValue)) -(define (lookup-atomic-register m reg) - (cond [(eq? reg 'val) - (machine-val m)] - [(eq? reg 'proc) - (machine-proc m)] - [(eq? reg 'argcount) - (machine-argcount m)])) - - -(: lookup-env-reference/closure-capture (machine EnvReference -> SlotValue)) -;; Capture values for the closure, given a set of environment references. -(define (lookup-env-reference/closure-capture m ref) - (cond [(EnvLexicalReference? ref) - (if (EnvLexicalReference-unbox? ref) - (ensure-primitive-value-box (env-ref m (EnvLexicalReference-depth ref))) - (env-ref m (EnvLexicalReference-depth ref)))] - [(EnvWholePrefixReference? ref) - (env-ref m (EnvWholePrefixReference-depth ref))])) - - -(: step-perform! (machine PerformStatement -> 'ok)) -(define (step-perform! m stmt) - (let: ([op : PrimitiveCommand (PerformStatement-op stmt)]) - (cond - - [(CheckToplevelBound!? op) - (let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))]) - (when (> (CheckToplevelBound!-pos op) - (length (toplevel-vals a-top))) - (printf "ERROR: toplevel is length ~s, but trying to refer to ~s.\n\n~s\n" - (length (toplevel-vals a-top)) - (CheckToplevelBound!-pos op) - (toplevel-names a-top)) - (for ([i (in-range (length (machine-env m)))]) - (let ([elt (env-ref m (ensure-natural i))]) - (when (toplevel? elt) - (printf "element ~s ia a toplevel of length ~s\n" - i (length (toplevel-names elt)))))) - (flush-output (current-output-port))) - (cond - [(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op))) - (error 'check-toplevel-bound! "Unbound identifier ~s" - (list-ref (toplevel-names a-top) (CheckToplevelBound!-pos op)))] - [else - 'ok]))] - - [(CheckClosureAndArity!? op) - (let: ([clos : SlotValue (machine-proc m)]) - (cond - [(closure? clos) - (if (arity-match? (closure-arity clos) - (ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op)))) - 'ok - (error 'check-closure-arity "arity mismatch: passed ~s args to ~s" - (ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op))) - (closure-display-name clos)))] - [else - (error 'check-closure-arity "not a closure: ~s" clos)]))] - - [(CheckPrimitiveArity!? op) - (let: ([clos : SlotValue (machine-proc m)]) - (cond - [(primitive-proc? clos) - (if (arity-match? (primitive-proc-arity clos) - (ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-num-args op)))) - 'ok - (error 'check-primitive-arity "arity mismatch: passed ~s args to ~s" - (ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-num-args op))) - (primitive-proc-display-name clos)))] - [else - (error 'check-primitive-arity "not a primitive: ~s" clos)]))] - - - [(ExtendEnvironment/Prefix!? op) - (env-push! m - (make-toplevel - (ExtendEnvironment/Prefix!-names op) - (map (lambda: ([name : (U False Symbol GlobalBucket ModuleVariable)]) - (cond [(eq? name #f) - (make-undefined)] - [(symbol? name) - (lookup-primitive name)] - [(GlobalBucket? name) - (lookup-primitive - (GlobalBucket-name name))] - [(ModuleVariable? name) - (lookup-module-variable m name)])) - (ExtendEnvironment/Prefix!-names op))))] - - [(InstallClosureValues!? op) - (let: ([a-proc : SlotValue (machine-proc m)]) - (cond - [(closure? a-proc) - (env-push-many! m (closure-vals a-proc))] - [else - (error 'step-perform "Procedure register doesn't hold a procedure: ~s" - a-proc)]))] - - [(FixClosureShellMap!? op) - (let: ([a-closure-shell : closure (ensure-closure (env-ref m (FixClosureShellMap!-depth op)))]) - (set-closure-vals! a-closure-shell - (map (lambda: ([d : Natural]) (env-ref m d)) - (FixClosureShellMap!-closed-vals op))) - 'ok)] - - - [(SetFrameCallee!? op) - (let* ([proc-value (ensure-closure (evaluate-oparg m (SetFrameCallee!-proc op)))] - [frame (ensure-CallFrame (control-top m))]) - (set-CallFrame-proc! frame proc-value) - 'ok)] - - [(SpliceListIntoStack!? op) - (let*: ([stack-index : Natural (ensure-natural (evaluate-oparg m (SpliceListIntoStack!-depth op)))] - [arg-list : (Listof PrimitiveValue) - (mutable-pair-list->list - (ensure-list (env-ref m stack-index)))]) - (set-machine-env! m (append (take (machine-env m) stack-index) - arg-list - (drop (machine-env m) (add1 stack-index)))) - (set-machine-stack-size! m (ensure-natural (+ (machine-stack-size m) - (length arg-list) - -1))) - (set-machine-argcount! m - (ensure-natural - (+ (ensure-natural (machine-argcount m)) - (length arg-list) - -1))) - 'ok)] - - [(UnspliceRestFromStack!? op) - (let: ([depth : Natural (ensure-natural - (evaluate-oparg m (UnspliceRestFromStack!-depth op)))] - [len : Natural (ensure-natural - (evaluate-oparg m (UnspliceRestFromStack!-length op)))]) - (let ([rest-arg (list->mutable-pair-list (map ensure-primitive-value - (take (drop (machine-env m) depth) len)))]) - (set-machine-env! m - (append (take (machine-env m) depth) - (list rest-arg) - (drop (machine-env m) (+ depth len)))) - (set-machine-stack-size! m (ensure-natural - (+ (machine-stack-size m) - (add1 (- len))))) - (set-machine-argcount! m (ensure-natural (+ (ensure-natural (machine-argcount m)) - (add1 (- len))))) - 'ok))] - - [(RestoreControl!? op) - (let: ([tag-value : ContinuationPromptTagValue - (let ([tag (RestoreControl!-tag op)]) - (cond - [(DefaultContinuationPromptTag? tag) - default-continuation-prompt-tag-value] - [(OpArg? tag) - (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))]) - (set-machine-control! m (compose-continuation-frames - (CapturedControl-frames (ensure-CapturedControl (env-ref m 0))) - (drop-continuation-to-tag (machine-control m) - tag-value))) - 'ok)] - - [(RestoreEnvironment!? op) - (set-machine-env! m (CapturedEnvironment-vals (ensure-CapturedEnvironment (env-ref m 1)))) - (set-machine-stack-size! m (length (machine-env m))) - 'ok] - - [(InstallContinuationMarkEntry!? op) - (let* ([a-frame (control-top m)] - [key (hash-ref (frame-temps a-frame) 'pendingContinuationMarkKey)] - [val (machine-val m)] - [marks (frame-marks a-frame)]) - (hash-set! marks - (ensure-primitive-value key) - (ensure-primitive-value val)) - 'ok)] - - [(RaiseContextExpectedValuesError!? op) - (error 'step "context expected ~a values, received ~a values." - (RaiseContextExpectedValuesError!-expected op) - (machine-argcount m))] - - [(RaiseArityMismatchError!? op) - (error 'step "expects ~s arguments, given ~a" - (RaiseArityMismatchError!-expected op) - (evaluate-oparg m (RaiseArityMismatchError!-received op)))] - - [(RaiseOperatorApplicationError!? op) - (error 'step "expected procedure, given ~a" - (evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))] - - [(RaiseUnimplementedPrimitiveError!? op) - (error 'step "Unimplemented kernel procedure ~a" - (RaiseUnimplementedPrimitiveError!-name op))] - - - [(InstallModuleEntry!? op) - (hash-set! (machine-modules m) - (ModuleLocator-name (InstallModuleEntry!-path op)) - (make-module-record (InstallModuleEntry!-name op) - (ModuleLocator-name - (InstallModuleEntry!-path op)) - (InstallModuleEntry!-entry-point op) - #f - (make-hash) - #f)) - 'ok] - - - [(MarkModuleInvoked!? op) - (let ([module-record - (hash-ref (machine-modules m) - (ModuleLocator-name (MarkModuleInvoked!-path op)))]) - (set-module-record-invoked?! module-record #t) - 'ok)] - [(AliasModuleAsMain!? op) - (let ([module-record - (hash-ref (machine-modules m) - (ModuleLocator-name (AliasModuleAsMain!-from op)))]) - (hash-set! (machine-modules m) - '*main* - module-record) - 'ok)] - [(FinalizeModuleInvokation!? op) - (let* ([mrecord - (hash-ref (machine-modules m) - (ModuleLocator-name (FinalizeModuleInvokation!-path op)))] - [ns (module-record-namespace mrecord)] - [top - (module-record-toplevel mrecord)]) - (cond - [(toplevel? top) - (for-each (lambda: ([n : (U False Symbol GlobalBucket ModuleVariable)] - [v : PrimitiveValue]) - (cond - [(eq? n #f) - (void)] - [(symbol? n) - (hash-set! ns n v)] - [(GlobalBucket? n) - (hash-set! ns (GlobalBucket-name n) v)] - [(ModuleVariable? n) - (hash-set! ns (ModuleVariable-name n) v)])) - (toplevel-names top) - (toplevel-vals top)) - 'ok] - [(eq? top #f) - ;; This should never happen. But let's make sure we can see the - ;; error. - (error 'FinalizeModuleInvokation - "internal error: toplevel hasn't been initialized.")]))]))) - - -(: lookup-module-variable (machine ModuleVariable -> PrimitiveValue)) -(define (lookup-module-variable m mv) - (cond - [(or (eq? - (ModuleLocator-name - (ModuleVariable-module-name mv)) - '#%kernel) - (eq? - (ModuleLocator-name - (ModuleVariable-module-name mv)) - 'whalesong/lang/kernel.rkt)) - (lookup-primitive (ModuleVariable-name mv))] - [else - - (let ([mrecord - (hash-ref (machine-modules m) - (ModuleLocator-name (ModuleVariable-module-name mv)))]) - (hash-ref (module-record-namespace mrecord) - (ModuleVariable-name mv)))])) - - - - -(: mutable-pair-list->list ((U Null MutablePair) -> (Listof PrimitiveValue))) -(define (mutable-pair-list->list mlst) - (cond - [(null? mlst) - '()] - [else - (cons (MutablePair-h mlst) - (mutable-pair-list->list (let ([t (MutablePair-t mlst)]) - (cond - [(null? t) - t] - [(MutablePair? t) - t] - [else - (error 'mutable-pair-list->list "Not a list: ~s" t)]))))])) - - -(: arity-match? (Arity Natural -> Boolean)) -(define (arity-match? an-arity n) - (cond - [(natural? an-arity) - (= n an-arity)] - [(ArityAtLeast? an-arity) - (>= n (ArityAtLeast-value an-arity))] - [(list? an-arity) - (ormap (lambda: ([atomic-arity : (U Natural ArityAtLeast)]) - (cond [(natural? atomic-arity) - (= n atomic-arity)] - [(ArityAtLeast? atomic-arity) - (>= n (ArityAtLeast-value atomic-arity))])) - an-arity)])) - - - - -(: compose-continuation-frames ((Listof frame) (Listof frame) -> (Listof frame))) -;; Stitch together the continuation. A PromptFrame must exist at the head of frames-2. -(define (compose-continuation-frames frames-1 frames-2) - (append frames-1 frames-2)) - - - - - -(: get-target-updater (Target -> (machine SlotValue -> 'ok))) -(define (get-target-updater t) - (cond - [(eq? t 'proc) - proc-update!] - [(eq? t 'val) - val-update!] - [(eq? t 'argcount) - argcount-update!] - [(EnvLexicalReference? t) - (lambda: ([m : machine] [v : SlotValue]) - (if (EnvLexicalReference-unbox? t) - (begin - (set-box! (ensure-primitive-value-box (env-ref m (EnvLexicalReference-depth t))) - (ensure-primitive-value v)) - 'ok) - (env-mutate! m (EnvLexicalReference-depth t) v)))] - [(EnvPrefixReference? t) - (lambda: ([m : machine] [v : SlotValue]) - (toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t))) - (EnvPrefixReference-pos t) - (ensure-primitive-value v)))] - [(PrimitivesReference? t) - (lambda: ([m : machine] [v : SlotValue]) - (set-primitive! (PrimitivesReference-name t) - (ensure-primitive-value v)) - 'ok)] - [(ControlFrameTemporary? t) - (lambda: ([m : machine] [v : SlotValue]) - (let ([ht (frame-temps (control-top m))]) - (hash-set! ht - (ControlFrameTemporary-name t) - (ensure-primitive-value v)) - 'ok))] - [(ModulePrefixTarget? t) - (lambda: ([m : machine] [v : SlotValue]) - (let ([module-record - (hash-ref (machine-modules m) - (ModuleLocator-name - (ModulePrefixTarget-path t)))]) - (set-module-record-toplevel! module-record - (ensure-toplevel v)) - 'ok))])) - - - -(: step-assign-primitive-operation! (machine AssignPrimOpStatement -> 'ok)) -(define (step-assign-primitive-operation! m stmt) - (let: ([op : PrimitiveOperator (AssignPrimOpStatement-op stmt)] - [target-updater! : (machine SlotValue -> 'ok) - (get-target-updater (AssignPrimOpStatement-target stmt))]) - (cond - [(GetCompiledProcedureEntry? op) - (let: ([a-proc : SlotValue (machine-proc m)]) - (cond - [(closure? a-proc) - (target-updater! m (closure-label a-proc))] - [else - (error 'get-compiled-procedure-entry)]))] - - [(MakeCompiledProcedure? op) - (target-updater! m (make-closure (MakeCompiledProcedure-label op) - (MakeCompiledProcedure-arity op) - (map (lambda: ([d : Natural]) (env-ref m d)) - (MakeCompiledProcedure-closed-vals op)) - (MakeCompiledProcedure-display-name op)))] - - [(MakeCompiledProcedureShell? op) - (target-updater! m (make-closure (MakeCompiledProcedureShell-label op) - (MakeCompiledProcedureShell-arity op) - '() - (MakeCompiledProcedureShell-display-name op)))] - - [(CaptureEnvironment? op) - (target-updater! m (make-CapturedEnvironment (drop (machine-env m) - (CaptureEnvironment-skip op))))] - [(CaptureControl? op) - (target-updater! m (evaluate-continuation-capture m op))] - - [(MakeBoxedEnvironmentValue? op) - (target-updater! m (box (ensure-primitive-value - (env-ref m (MakeBoxedEnvironmentValue-depth op)))))] - - [(CallKernelPrimitiveProcedure? op) - (target-updater! m (evaluate-kernel-primitive-procedure-call m op))]))) - - -(: evaluate-continuation-capture (machine CaptureControl -> SlotValue)) -(define (evaluate-continuation-capture m op) - (let: ([frames : (Listof frame) (drop (machine-control m) - (CaptureControl-skip op))] - [tag : ContinuationPromptTagValue - (let ([tag (CaptureControl-tag op)]) - (cond - [(DefaultContinuationPromptTag? tag) - default-continuation-prompt-tag-value] - [(OpArg? tag) - (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))]) - (make-CapturedControl (take-continuation-to-tag frames tag)))) - - -(: take-continuation-to-tag ((Listof frame) ContinuationPromptTagValue -> (Listof frame))) -(define (take-continuation-to-tag frames tag) - (cond - [(empty? frames) - (error 'trim-continuation-at-tag "Unable to find continuation tag value ~s" tag)] - [else - (let ([a-frame (first frames)]) - (cond - [(GenericFrame? a-frame) - (cons a-frame (take-continuation-to-tag (rest frames) tag))] - [(CallFrame? a-frame) - (cons a-frame (take-continuation-to-tag (rest frames) tag))] - [(PromptFrame? a-frame) - (cond - [(eq? (PromptFrame-tag a-frame) tag) - '()] - [else - (cons a-frame (take-continuation-to-tag (rest frames) tag))])]))])) - - -(: drop-continuation-to-tag ((Listof frame) ContinuationPromptTagValue -> (Listof frame))) -;; Drops continuation frames until we reach the appropriate one. -(define (drop-continuation-to-tag frames tag) - (cond - [(empty? frames) - (error 'trim-continuation-at-tag "Unable to find continuation tag value ~s" tag)] - [else - (let ([a-frame (first frames)]) - (cond - [(GenericFrame? a-frame) - (drop-continuation-to-tag (rest frames) tag)] - [(CallFrame? a-frame) - (drop-continuation-to-tag (rest frames) tag)] - [(PromptFrame? a-frame) - (cond - [(eq? (PromptFrame-tag a-frame) tag) - frames] - [else - (drop-continuation-to-tag (rest frames) tag)])]))])) - - -(: list->mutable-pair-list ((Listof PrimitiveValue) -> PrimitiveValue)) -(define (list->mutable-pair-list rand-vals) - (let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals]) - (cond [(empty? rand-vals) - null] - [else - (make-MutablePair (first rand-vals) - (loop (rest rand-vals)))]))) - - - -(: evaluate-kernel-primitive-procedure-call (machine CallKernelPrimitiveProcedure -> PrimitiveValue)) -(define (evaluate-kernel-primitive-procedure-call m op) - (let: ([op : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] - [rand-vals : (Listof PrimitiveValue) - (map (lambda: ([a : OpArg]) - (ensure-primitive-value (evaluate-oparg m a))) - (CallKernelPrimitiveProcedure-operands op))]) - (case op - [(+) - (apply + (map ensure-number rand-vals))] - [(-) - (apply - (ensure-number (first rand-vals)) (map ensure-number (rest rand-vals)))] - [(*) - (apply * (map ensure-number rand-vals))] - [(/) - (apply / (ensure-number (first rand-vals)) (map ensure-number (rest rand-vals)))] - [(add1) - (add1 (ensure-number (first rand-vals)))] - [(sub1) - (sub1 (ensure-number (first rand-vals)))] - [(<) - (chain-compare < (map ensure-real-number rand-vals))] - [(<=) - (chain-compare <= (map ensure-real-number rand-vals))] - [(=) - (chain-compare = (map ensure-real-number rand-vals))] - [(>) - (chain-compare > (map ensure-real-number rand-vals))] - [(>=) - (chain-compare >= (map ensure-real-number rand-vals))] - [(cons) - (make-MutablePair (first rand-vals) (second rand-vals))] - [(car) - (MutablePair-h (ensure-mutable-pair (first rand-vals)))] - [(cdr) - (MutablePair-t (ensure-mutable-pair (first rand-vals)))] - [(list) - (list->mutable-pair-list rand-vals)] - [(null?) - (null? (first rand-vals))] - [(pair?) - (MutablePair? (first rand-vals))] - [(not) - (not (first rand-vals))] - [(eq?) - (eq? (first rand-vals) (second rand-vals))] - [else - (error 'evaluate-kernel-primitive-procedure-call "missing operator: ~s\n" op)]))) - -(: chain-compare (All (A) (A A -> Boolean) (Listof A) -> Boolean)) -(define (chain-compare f vals) - (cond - [(empty? vals) - #t] - [(empty? (rest vals)) - #t] - [else - (and (f (first vals) (second vals)) - (chain-compare f (rest vals)))])) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(: evaluate-oparg (machine OpArg -> SlotValue)) -(define (evaluate-oparg m an-oparg) - (cond - [(Const? an-oparg) - (racket->PrimitiveValue (Const-const an-oparg))] - - [(Label? an-oparg) - (Label-name an-oparg)] - - [(Reg? an-oparg) - (let: ([n : AtomicRegisterSymbol (Reg-name an-oparg)]) - (cond - [(eq? n 'proc) - (machine-proc m)] - [(eq? n 'val) - (machine-val m)] - [(eq? n 'argcount) - (machine-argcount m)]))] - - [(EnvLexicalReference? an-oparg) - (let*: ([v : SlotValue - (env-ref m (EnvLexicalReference-depth an-oparg))] - [v : SlotValue - (if (EnvLexicalReference-unbox? an-oparg) - (unbox (ensure-primitive-value-box v)) - v)]) - (cond - [(toplevel? v) - (error 'evaluate-oparg - "Unexpected toplevel at depth ~s" - (EnvLexicalReference-depth an-oparg))] - [else v]))] - - [(EnvPrefixReference? an-oparg) - (let: ([a-top : SlotValue (env-ref m (EnvPrefixReference-depth an-oparg))]) - (cond - [(toplevel? a-top) - (list-ref (toplevel-vals a-top) - (EnvPrefixReference-pos an-oparg))] - [else - (error 'evaluate-oparg "not a toplevel: ~s" a-top)]))] - - - [(EnvWholePrefixReference? an-oparg) - (let: ([v : SlotValue - (list-ref (machine-env m) (EnvWholePrefixReference-depth an-oparg))]) - (cond - [(toplevel? v) - v] - [else - (error 'evaluate-oparg "Internal error: not a toplevel at depth ~s: ~s" - (EnvWholePrefixReference-depth an-oparg) - v)]))] - - [(SubtractArg? an-oparg) - (- (ensure-number (evaluate-oparg m (SubtractArg-lhs an-oparg))) - (ensure-number (evaluate-oparg m (SubtractArg-rhs an-oparg))))] - - - - [(ControlStackLabel? an-oparg) - (let ([frame (ensure-frame (first (machine-control m)))]) - (cond - [(GenericFrame? frame) - (error 'GetControlStackLabel)] - [(PromptFrame? frame) - (let ([label (PromptFrame-return frame)]) - (cond [(halt? label) - end-of-program-text] - [else - (LinkedLabel-label label)]))] - [(CallFrame? frame) - (let ([label (CallFrame-return frame)]) - (cond - [(halt? label) - end-of-program-text] - [else - (LinkedLabel-label label)]))]))] - - [(ControlStackLabel/MultipleValueReturn? an-oparg) - (let ([frame (ensure-frame (first (machine-control m)))]) - (cond - [(GenericFrame? frame) - (error 'GetControlStackLabel/MultipleValueReturn)] - [(PromptFrame? frame) - (let ([label (PromptFrame-return frame)]) - (cond - [(halt? label) - end-of-program-text] - [else - (LinkedLabel-linked-to label)]))] - [(CallFrame? frame) - (let ([label (CallFrame-return frame)]) - (cond - [(halt? label) - end-of-program-text] - [else - (LinkedLabel-linked-to label)]))]))] - - [(ControlFrameTemporary? an-oparg) - (let ([ht (frame-temps (control-top m))]) - (hash-ref ht - (ControlFrameTemporary-name an-oparg)))] - - [(CompiledProcedureEntry? an-oparg) - (let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureEntry-proc an-oparg)))]) - (closure-label proc))] - - [(CompiledProcedureClosureReference? an-oparg) - (let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureClosureReference-proc an-oparg)))]) - (list-ref (closure-vals proc) (CompiledProcedureClosureReference-n an-oparg)))] - - [(PrimitiveKernelValue? an-oparg) - (lookup-primitive (PrimitiveKernelValue-id an-oparg))] - - [(ModuleEntry? an-oparg) - (let ([a-module (hash-ref (machine-modules m) - (ModuleLocator-name (ModuleEntry-name an-oparg)))]) - (module-record-label a-module))] - - [(IsModuleInvoked? an-oparg) - (let ([a-module (hash-ref (machine-modules m) - (ModuleLocator-name (IsModuleInvoked-name an-oparg)))]) - (module-record-invoked? a-module))] - - [(IsModuleLinked? an-oparg) - (hash-has-key? (machine-modules m) - (ModuleLocator-name (IsModuleLinked-name an-oparg)))] - - [(VariableReference? an-oparg) - (let ([t (VariableReference-toplevel an-oparg)]) - (make-ToplevelReference (ensure-toplevel (env-ref m (ToplevelRef-depth t))) - (ToplevelRef-pos t)))])) - - - - -(: ensure-closure-or-false (SlotValue -> (U closure #f))) -(define (ensure-closure-or-false v) - (if (or (closure? v) (eq? v #f)) - v - (error 'ensure-closure-or-false))) - -(: ensure-closure (SlotValue -> closure)) -(define (ensure-closure v) - (if (closure? v) - v - (error 'ensure-closure))) - -(: ensure-CallFrame (Any -> CallFrame)) -(define (ensure-CallFrame v) - (if (CallFrame? v) - v - (error 'ensure-CallFrame "not a CallFrame: ~s" v))) - -(: ensure-continuation-prompt-tag-value (Any -> ContinuationPromptTagValue)) -(define (ensure-continuation-prompt-tag-value v) - (if (ContinuationPromptTagValue? v) - v - (error 'ensure-ContinuationPromptTagValue "not a ContinuationPromptTagValue: ~s" v))) - - -(: ensure-symbol (Any -> Symbol)) -;; Make sure the value is a symbol. -(define (ensure-symbol v) - (cond - [(symbol? v) - v] - [else - (error 'ensure-symbol)])) - - -(: ensure-toplevel (Any -> toplevel)) -(define (ensure-toplevel v) - (cond - [(toplevel? v) - v] - [else - (error 'ensure-toplevel)])) - -(define-predicate natural? Natural) - -(: ensure-natural (Any -> Natural)) -(define (ensure-natural x) - (if (natural? x) - x - (error 'ensure-natural "not a natural: ~s" x))) - -(: ensure-number (Any -> Number)) -(define (ensure-number x) - (if (number? x) - x - (error 'ensure-number "Not a number: ~s" x))) - - - -(: ensure-real-number (Any -> Real)) -(define (ensure-real-number x) - (if (real? x) - x - (error 'ensure-number "Not a number: ~s" x))) - - -(: ensure-mutable-pair (Any -> MutablePair)) -(define (ensure-mutable-pair x) - (if (MutablePair? x) - x - (error 'ensure-mutable-pair "not a mutable pair: ~s" x))) - -(: ensure-prompt-frame (Any -> PromptFrame)) -(define (ensure-prompt-frame x) - (if (PromptFrame? x) - x - (error 'ensure-prompt-frame "not a PromptFrame: ~s" x))) - -(: ensure-frame (Any -> frame)) -(define (ensure-frame x) - (if (frame? x) - x - (error 'ensure-frame "not a frame: ~s" x))) - - -(: ensure-CapturedControl (Any -> CapturedControl)) -(define (ensure-CapturedControl x) - (if (CapturedControl? x) - x - (error 'ensure-CapturedControl "~s" x))) - - - - -(: ensure-CapturedEnvironment (Any -> CapturedEnvironment)) -(define (ensure-CapturedEnvironment x) - (if (CapturedEnvironment? x) - x - (error 'ensure-CapturedEnvironment "~s" x))) - - -(: current-instruction (machine -> Statement)) -(define (current-instruction m) - (match m - [(struct machine (val proc argcount env control pc text - modules stack-size jump-table)) - (vector-ref text pc)])) - - - -(: val-update! (machine SlotValue -> 'ok)) -(define (val-update! m v) - (set-machine-val! m v) - 'ok) - -(: argcount-update! (machine SlotValue -> 'ok)) -(define (argcount-update! m v) - (set-machine-argcount! m v) - 'ok) - -(: proc-update! (machine SlotValue -> 'ok)) -(define (proc-update! m v) - (set-machine-proc! m v) - 'ok) - - -(: env-push! (machine SlotValue -> 'ok)) -(define (env-push! m v) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-env! m (cons v env)) - (set-machine-stack-size! m (add1 stack-size)) - 'ok])) - -(: env-push-many! (machine (Listof SlotValue) -> 'ok)) -(define (env-push-many! m vs) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-env! m (append vs env)) - (set-machine-stack-size! m (+ stack-size (length vs))) - 'ok])) - - -(: env-ref (machine Natural -> SlotValue)) -(define (env-ref m i) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (list-ref env i)])) - -(: env-mutate! (machine Natural SlotValue -> 'ok)) -(define (env-mutate! m i v) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-env! m (list-replace env i v)) - 'ok])) - - -(: list-replace (All (A) (Listof A) Natural A -> (Listof A))) -(define (list-replace l i v) - (cond - [(= i 0) - (cons v (rest l))] - [else - (cons (first l) - (list-replace (rest l) (sub1 i) v))])) - - -(: env-pop! (machine Natural Natural -> 'ok)) -(define (env-pop! m n skip) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-env! m (append (take env skip) - (drop env (+ skip n)))) - (set-machine-stack-size! m (ensure-natural (- stack-size n))) - 'ok])) - - -(: control-push! (machine frame -> 'ok)) -(define (control-push! m a-frame) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-control! m (cons a-frame control)) - 'ok])) - - -(: control-pop! (machine -> 'ok)) -(define (control-pop! m) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-control! m (rest control)) - 'ok])) - -(: control-top (machine -> frame)) -(define (control-top m) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (first control)])) - - - -(: increment-pc! (machine -> 'ok)) -(define (increment-pc! m) - (set-machine-pc! m (add1 (machine-pc m))) - 'ok) - - - -(: jump! (machine Symbol -> 'ok)) -;; Jumps directly to the instruction at the given label. -(define (jump! m l) - (match m - [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) - (set-machine-pc! m (hash-ref jump-table l)) - 'ok])) - - - - -(: toplevel-mutate! (toplevel Natural PrimitiveValue -> 'ok)) -(define (toplevel-mutate! a-top index v) - (set-toplevel-vals! a-top (append (take (toplevel-vals a-top) index) - (list v) - (drop (toplevel-vals a-top) (add1 index)))) - 'ok)