#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" "../expression-structs.rkt" "../il-structs.rkt" "../lexical-structs.rkt" "../bootstrapped-primitives.rkt" "../kernel-primitives.rkt" "../expression-structs.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)] [(TestAndBranchStatement? 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 TestAndBranchStatement -> 'ok)) (define (step-test-and-branch! m stmt) (let: ([test : PrimitiveTest (TestAndBranchStatement-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 (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)] [(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]))] [(CheckClosureArity!? op) (let: ([clos : SlotValue (machine-proc m)]) (cond [(closure? clos) (if (arity-match? (closure-arity clos) (ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op)))) 'ok (error 'check-closure-arity "arity mismatch: passed ~s args to ~s" (ensure-natural (evaluate-oparg m (CheckClosureArity!-arity 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!-arity op)))) 'ok (error 'check-primitive-arity "arity mismatch: passed ~s args to ~s" (ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity 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-primitive (ModuleVariable-name 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)))] [(InstallModuleEntry!? op) (printf "installing module ~s\n" (ModuleName-name (InstallModuleEntry!-path op))) (hash-set! (machine-modules m) (ModuleName-name (InstallModuleEntry!-path op)) (make-module-record (InstallModuleEntry!-name op) (ModuleName-name (InstallModuleEntry!-path op)) (InstallModuleEntry!-entry-point op) #f (make-hash))) 'ok]))) (: 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))])) (: 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) (ensure-natural (machine-argcount m))))]) (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)]))] [(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))] [(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) (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))) (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)