779 lines
28 KiB
Racket
779 lines
28 KiB
Racket
#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 "il-structs.rkt"
|
|
"lexical-structs.rkt"
|
|
"simulator-structs.rkt"
|
|
"bootstrapped-primitives.rkt"
|
|
"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 -> PrimitiveValue)]
|
|
[racket->PrimitiveValue (Any -> PrimitiveValue)])
|
|
|
|
|
|
(provide new-machine can-step? step! current-instruction
|
|
current-simulated-output-port
|
|
machine-control-size)
|
|
|
|
|
|
(define current-simulated-output-port (make-parameter (current-output-port)))
|
|
|
|
|
|
(: 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)
|
|
(cond [with-bootstrapping-code?
|
|
(append (get-bootstrapping-code)
|
|
program-text)]
|
|
[else
|
|
program-text])])
|
|
(let: ([m : machine (make-machine (make-undefined)
|
|
(make-undefined)
|
|
'()
|
|
'()
|
|
0
|
|
(list->vector program-text)
|
|
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 (PairedLabel? stmt)
|
|
(hash-set! (machine-jump-table m) (PairedLabel-label stmt) i))
|
|
(loop (add1 i)))))
|
|
m))]))
|
|
|
|
|
|
|
|
(: machine-control-size (machine -> Natural))
|
|
(define (machine-control-size m)
|
|
(length (machine-control m)))
|
|
|
|
|
|
|
|
|
|
(: 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]
|
|
[(PairedLabel? 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)]
|
|
[(TestAndBranchStatement? i)
|
|
(step-test-and-branch! m i)]
|
|
[(PopEnvironment? i)
|
|
(step-pop-environment! m i)]
|
|
[(PushEnvironment? i)
|
|
(step-push-environment! m i)]
|
|
[(PushControlFrame? 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)]
|
|
[(PopControlFrame/Prompt? i)
|
|
(step-pop-control-frame! m i)])])
|
|
(increment-pc! m)))
|
|
|
|
|
|
|
|
|
|
(: step-goto! (machine GotoStatement -> 'ok))
|
|
(define (step-goto! m a-goto)
|
|
(let: ([t : (U Label Reg) (GotoStatement-target a-goto)])
|
|
(cond [(Label? t)
|
|
(jump! m (Label-name t))]
|
|
[(Reg? t)
|
|
(let: ([reg : AtomicRegisterSymbol (Reg-name t)])
|
|
(cond [(AtomicRegisterSymbol? reg)
|
|
(cond [(eq? reg 'val)
|
|
(jump! m (ensure-symbol (machine-val m)))]
|
|
[(eq? reg 'proc)
|
|
(jump! m (ensure-symbol (machine-proc m)))])]))])))
|
|
|
|
(: 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 (PopEnvironment-n stmt) (PopEnvironment-skip stmt)))
|
|
|
|
|
|
(: step-push-control-frame! (machine PushControlFrame -> 'ok))
|
|
(define (step-push-control-frame! m stmt)
|
|
(control-push! m (make-CallFrame (PushControlFrame-label stmt)
|
|
(ensure-closure-or-false (machine-proc m)))))
|
|
|
|
(: 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))))
|
|
|
|
|
|
|
|
(: step-pop-control-frame! (machine (U PopControlFrame PopControlFrame/Prompt) -> 'ok))
|
|
(define (step-pop-control-frame! m stmt)
|
|
(let: ([l : Symbol (control-pop! m)])
|
|
'ok))
|
|
|
|
(: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
|
|
(define (step-test-and-branch! m stmt)
|
|
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
|
|
[argval : SlotValue (lookup-atomic-register m (TestAndBranchStatement-register stmt))])
|
|
(if (cond
|
|
[(eq? test 'false?)
|
|
(not argval)]
|
|
[(eq? test 'primitive-procedure?)
|
|
(primitive-proc? argval)])
|
|
(jump! m (TestAndBranchStatement-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)]))
|
|
|
|
|
|
(: 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)))])
|
|
(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]))]
|
|
|
|
[(CheckClosureArity!? op)
|
|
(let: ([clos : SlotValue (machine-proc m)])
|
|
(cond
|
|
[(closure? clos)
|
|
(if (= (closure-arity clos)
|
|
(CheckClosureArity!-arity op))
|
|
'ok
|
|
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
|
|
(CheckClosureArity!-arity op)
|
|
(closure-display-name clos)))]
|
|
[else
|
|
(error 'check-closure-arity "not a closure: ~s" clos)]))]
|
|
|
|
[(ExtendEnvironment/Prefix!? op)
|
|
(env-push! m
|
|
(make-toplevel (ExtendEnvironment/Prefix!-names op)
|
|
(map (lambda: ([name : (U Symbol ModuleVariable False)])
|
|
(cond [(symbol? name)
|
|
(lookup-primitive name)]
|
|
[(ModuleVariable? name)
|
|
(lookup-primitive (ModuleVariable-name name))]
|
|
[(eq? name #f)
|
|
(make-undefined)]))
|
|
(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)]
|
|
|
|
[(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])))
|
|
|
|
|
|
|
|
(: 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!]
|
|
[(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)]))
|
|
|
|
|
|
(: 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)))]
|
|
|
|
[(ApplyPrimitiveProcedure? op)
|
|
(let: ([prim : SlotValue (machine-proc m)]
|
|
[args : (Listof PrimitiveValue)
|
|
(map ensure-primitive-value (take (machine-env m)
|
|
(ApplyPrimitiveProcedure-arity op)))])
|
|
(cond
|
|
[(primitive-proc? prim)
|
|
(target-updater! m (ensure-primitive-value
|
|
(parameterize ([current-output-port
|
|
(current-simulated-output-port)])
|
|
(apply (primitive-proc-f prim)
|
|
m
|
|
args))))]
|
|
[else
|
|
(error 'apply-primitive-procedure)]))]
|
|
|
|
[(GetControlStackLabel? op)
|
|
(target-updater! m (let ([frame (ensure-frame (first (machine-control m)))])
|
|
(cond
|
|
[(PromptFrame? frame)
|
|
(PromptFrame-return frame)]
|
|
[(CallFrame? frame)
|
|
(CallFrame-return frame)])))]
|
|
|
|
[(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
|
|
[(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
|
|
[(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)])]))]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(: 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)
|
|
(let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals])
|
|
(cond [(empty? rand-vals)
|
|
null]
|
|
[else
|
|
(make-MutablePair (first rand-vals)
|
|
(loop (rest rand-vals)))]))]
|
|
[(null?)
|
|
(null? (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)]))]
|
|
|
|
[(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)]))]))
|
|
|
|
|
|
(: 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)))
|
|
|
|
(: 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)]))
|
|
|
|
(: ensure-natural (Integer -> Natural))
|
|
(define (ensure-natural x)
|
|
(if (>= x 0)
|
|
x
|
|
(error 'ensure-natural)))
|
|
|
|
(: 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 env control pc text
|
|
stack-size jump-table))
|
|
(vector-ref text pc)]))
|
|
|
|
|
|
|
|
(: val-update! (machine SlotValue -> 'ok))
|
|
(define (val-update! m v)
|
|
(set-machine-val! 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 env control pc text 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 env control pc text 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 env control pc text 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 env control pc text 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 env control pc text 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 env control pc text 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 env control pc text stack-size jump-table))
|
|
(set-machine-control! m (rest control))
|
|
'ok]))
|
|
|
|
|
|
|
|
(: 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 env control pc text 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)
|