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

changed simulator so it's a mutable structure; I'll need this to implement call/cc easily as a primitive, since it's going to mutate the machine.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-11 16:03:37 -05:00
parent 13a29cee72
commit da3568d3d2
5 changed files with 146 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
simulator-prims.rkt
View File

@ -13,7 +13,7 @@
(with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))]) (with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))])
(syntax/loc stx (syntax/loc stx
(let ([prim-name (make-primitive-proc (let ([prim-name (make-primitive-proc
(lambda args (lambda (machine return-label . args)
(apply name args)))] (apply name args)))]
...) ...)
(lambda (n) (lambda (n)
@ -28,6 +28,11 @@
(make-undefined)] (make-undefined)]
)))))])) )))))]))
#;(define my-callcc
(make-primitive-proc
(lambda (machine return-label k)
(make-primitive-proc (lambda (m2 r2 k2)
...)))))

12
simulator-structs.rkt
View File

@ -7,9 +7,10 @@
(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean (define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
Null Void Null Void
undefined
primitive-proc primitive-proc
closure closure
undefined
(Pairof PrimitiveValue PrimitiveValue) (Pairof PrimitiveValue PrimitiveValue)
))) )))
@ -28,7 +29,8 @@
;; other metrics for debugging ;; other metrics for debugging
[stack-size : Natural] [stack-size : Natural]
) )
#:transparent) #:transparent
#:mutable)
(define-struct: frame ([return : Symbol] (define-struct: frame ([return : Symbol]
@ -47,7 +49,7 @@
;; Primitive procedure wrapper ;; Primitive procedure wrapper
(define-struct: primitive-proc ([f : (PrimitiveValue * -> PrimitiveValue)]) (define-struct: primitive-proc ([f : (machine Symbol PrimitiveValue * -> PrimitiveValue)])
#:transparent) #:transparent)
@ -58,6 +60,10 @@
[vals : (Listof SlotValue)]) [vals : (Listof SlotValue)])
#:transparent) #:transparent)
;; undefined value ;; undefined value
(define-struct: undefined () (define-struct: undefined ()
#:transparent) #:transparent)

238
simulator.rkt
View File

@ -15,7 +15,7 @@
[lookup-primitive (Symbol -> PrimitiveValue)]) [lookup-primitive (Symbol -> PrimitiveValue)])
(provide new-machine can-step? step current-instruction (provide new-machine can-step? step! current-instruction
machine-control-size) machine-control-size)
@ -40,97 +40,92 @@
(vector-length (machine-text m)))) (vector-length (machine-text m))))
(: step (machine -> machine)) (: step! (machine -> Void))
;; Take one simulation step. ;; Take one simulation step.
(define (step m) (define (step! m)
(let: ([i : Statement (current-instruction m)]) (let: ([i : Statement (current-instruction m)])
(increment-pc
(cond (cond
[(symbol? i) [(symbol? i)
m] (void)]
[(AssignImmediateStatement? i) [(AssignImmediateStatement? i)
(step-assign-immediate m i)] (step-assign-immediate! m i)]
[(AssignPrimOpStatement? i) [(AssignPrimOpStatement? i)
(step-assign-primitive-operation m i)] (step-assign-primitive-operation! m i)]
[(PerformStatement? i) [(PerformStatement? i)
(step-perform m i)] (step-perform! m i)]
[(GotoStatement? i) [(GotoStatement? i)
(step-goto m i)] (step-goto! m i)]
[(TestAndBranchStatement? i) [(TestAndBranchStatement? i)
(step-test-and-branch m i)] (step-test-and-branch! m i)]
[(PopEnvironment? i) [(PopEnvironment? i)
(step-pop-environment m i)] (step-pop-environment! m i)]
[(PushEnvironment? i) [(PushEnvironment? i)
(step-push-environment m i)] (step-push-environment! m i)]
[(PushControlFrame? i) [(PushControlFrame? i)
(step-push-control-frame m i)] (step-push-control-frame! m i)]
[(PopControlFrame? i) [(PopControlFrame? i)
(step-pop-control-frame m i)])))) (step-pop-control-frame! m i)]))
(increment-pc! m))
(: step-goto (machine GotoStatement -> machine)) (: step-goto! (machine GotoStatement -> Void))
(define (step-goto m a-goto) (define (step-goto! m a-goto)
(let: ([t : (U Label Reg) (GotoStatement-target a-goto)]) (let: ([t : (U Label Reg) (GotoStatement-target a-goto)])
(cond [(Label? t) (cond [(Label? t)
(jump m (Label-name t))] (jump! m (Label-name t))]
[(Reg? t) [(Reg? t)
(let: ([reg : AtomicRegisterSymbol (Reg-name t)]) (let: ([reg : AtomicRegisterSymbol (Reg-name t)])
(cond [(AtomicRegisterSymbol? reg) (cond [(AtomicRegisterSymbol? reg)
(cond [(eq? reg 'val) (cond [(eq? reg 'val)
(jump m (ensure-symbol (machine-val m)))] (jump! m (ensure-symbol (machine-val m)))]
[(eq? reg 'proc) [(eq? reg 'proc)
(jump m (ensure-symbol (machine-proc m)))])]))]))) (jump! m (ensure-symbol (machine-proc m)))])]))])))
(: step-assign-immediate (machine AssignImmediateStatement -> machine)) (: step-assign-immediate! (machine AssignImmediateStatement -> Void))
(define (step-assign-immediate m stmt) (define (step-assign-immediate! m stmt)
(let: ([t : Target (AssignImmediateStatement-target stmt)] (let: ([t : Target (AssignImmediateStatement-target stmt)]
[v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))]) [v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))])
(cond [(eq? t 'proc) (cond [(eq? t 'proc)
(proc-update m v)] (proc-update! m v)]
[(eq? t 'val) [(eq? t 'val)
(val-update m v)] (val-update! m v)]
[(EnvLexicalReference? t) [(EnvLexicalReference? t)
(env-mutate m (EnvLexicalReference-depth t) v)] (env-mutate! m (EnvLexicalReference-depth t) v)]
[(EnvPrefixReference? t) [(EnvPrefixReference? t)
(toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t))) (toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
(EnvPrefixReference-pos t) (EnvPrefixReference-pos t)
(ensure-primitive-value v)) (ensure-primitive-value v))])))
m])))
(: step-push-environment (machine PushEnvironment -> machine)) (: step-push-environment! (machine PushEnvironment -> Void))
(define (step-push-environment m stmt) (define (step-push-environment! m stmt)
(let: loop : machine ([m : machine m] (let: loop : Void ([n : Natural (PushEnvironment-n stmt)])
[n : Natural (PushEnvironment-n stmt)])
(cond (cond
[(= n 0) [(= n 0)
m] (void)]
[else [else
(loop (env-push m (make-undefined)) (env-push! m (make-undefined))
(sub1 n))]))) (loop (sub1 n))])))
(: step-pop-environment (machine PopEnvironment -> machine)) (: step-pop-environment! (machine PopEnvironment -> Void))
(define (step-pop-environment m stmt) (define (step-pop-environment! m stmt)
(env-pop m (env-pop! m (PopEnvironment-n stmt) (PopEnvironment-skip stmt)))
(PopEnvironment-n stmt)
(PopEnvironment-skip stmt)))
(: step-push-control-frame (machine PushControlFrame -> machine)) (: step-push-control-frame! (machine PushControlFrame -> Void))
(define (step-push-control-frame m stmt) (define (step-push-control-frame! m stmt)
(control-push m (make-frame (PushControlFrame-label stmt) (control-push! m (make-frame (PushControlFrame-label stmt)
(ensure-closure-or-false (machine-proc m))))) (ensure-closure-or-false (machine-proc m)))))
(: step-pop-control-frame (machine PopControlFrame -> machine)) (: step-pop-control-frame! (machine PopControlFrame -> Void))
(define (step-pop-control-frame m stmt) (define (step-pop-control-frame! m stmt)
(let-values: ([([m : machine] (let: ([l : Symbol (control-pop! m)])
[l : Symbol]) (void)))
(control-pop m)])
m))
(: step-test-and-branch (machine TestAndBranchStatement -> machine)) (: step-test-and-branch! (machine TestAndBranchStatement -> Void))
(define (step-test-and-branch m stmt) (define (step-test-and-branch! m stmt)
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)] (let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
[argval : SlotValue (lookup-atomic-register m (TestAndBranchStatement-register stmt))]) [argval : SlotValue (lookup-atomic-register m (TestAndBranchStatement-register stmt))])
(if (cond (if (cond
@ -138,8 +133,8 @@
(not argval)] (not argval)]
[(eq? test 'primitive-procedure?) [(eq? test 'primitive-procedure?)
(primitive-proc? argval)]) (primitive-proc? argval)])
(jump m (TestAndBranchStatement-label stmt)) (jump! m (TestAndBranchStatement-label stmt))
m))) (void))))
(: lookup-atomic-register (machine AtomicRegisterSymbol -> SlotValue)) (: lookup-atomic-register (machine AtomicRegisterSymbol -> SlotValue))
@ -158,8 +153,8 @@
(env-ref m (EnvWholePrefixReference-depth ref))])) (env-ref m (EnvWholePrefixReference-depth ref))]))
(: step-perform (machine PerformStatement -> machine)) (: step-perform! (machine PerformStatement -> Void))
(define (step-perform m stmt) (define (step-perform! m stmt)
(let: ([op : PrimitiveCommand (PerformStatement-op stmt)]) (let: ([op : PrimitiveCommand (PerformStatement-op stmt)])
(cond (cond
@ -170,7 +165,7 @@
(error 'check-toplevel-bound! "Unbound identifier ~s" (error 'check-toplevel-bound! "Unbound identifier ~s"
(CheckToplevelBound!-name op))] (CheckToplevelBound!-name op))]
[else [else
m]))] (void)]))]
[(CheckClosureArity!? op) [(CheckClosureArity!? op)
(let: ([clos : SlotValue (machine-proc m)]) (let: ([clos : SlotValue (machine-proc m)])
@ -178,60 +173,58 @@
[(closure? clos) [(closure? clos)
(if (= (closure-arity clos) (if (= (closure-arity clos)
(CheckClosureArity!-arity op)) (CheckClosureArity!-arity op))
m (void)
(error 'check-closure-arity "arity mismatch"))] (error 'check-closure-arity "arity mismatch"))]
[else [else
(error 'check-closure-arity "not a closure")]))] (error 'check-closure-arity "not a closure")]))]
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)
(env-push m (env-push! m
(make-toplevel (map lookup-primitive (make-toplevel (map lookup-primitive
(ExtendEnvironment/Prefix!-names op))))] (ExtendEnvironment/Prefix!-names op))))]
[(InstallClosureValues!? op) [(InstallClosureValues!? op)
(let: ([a-proc : SlotValue (machine-proc m)]) (let: ([a-proc : SlotValue (machine-proc m)])
(cond (cond
[(closure? a-proc) [(closure? a-proc)
(env-push-many m (env-push-many! m (closure-vals a-proc))]
(closure-vals a-proc))]
[else [else
(error 'step-perform "Procedure register doesn't hold a procedure: ~s" (error 'step-perform "Procedure register doesn't hold a procedure: ~s"
a-proc)]))]))) a-proc)]))])))
(: get-target-updater (Target -> (machine SlotValue -> machine))) (: get-target-updater (Target -> (machine SlotValue -> Void)))
(define (get-target-updater t) (define (get-target-updater t)
(cond (cond
[(eq? t 'proc) [(eq? t 'proc)
proc-update] proc-update!]
[(eq? t 'val) [(eq? t 'val)
val-update] val-update!]
[(EnvLexicalReference? t) [(EnvLexicalReference? t)
(lambda: ([m : machine] [v : SlotValue]) (lambda: ([m : machine] [v : SlotValue])
(env-mutate m (EnvLexicalReference-depth t) v))] (env-mutate! m (EnvLexicalReference-depth t) v))]
[(EnvPrefixReference? t) [(EnvPrefixReference? t)
(lambda: ([m : machine] [v : SlotValue]) (lambda: ([m : machine] [v : SlotValue])
(toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t))) (toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
(EnvPrefixReference-pos t) (EnvPrefixReference-pos t)
(ensure-primitive-value v)) (ensure-primitive-value v)))]))
m)]))
(: step-assign-primitive-operation (machine AssignPrimOpStatement -> machine)) (: step-assign-primitive-operation! (machine AssignPrimOpStatement -> Void))
(define (step-assign-primitive-operation m stmt) (define (step-assign-primitive-operation! m stmt)
(let: ([op : PrimitiveOperator (AssignPrimOpStatement-op stmt)] (let: ([op : PrimitiveOperator (AssignPrimOpStatement-op stmt)]
[target-updater : (machine SlotValue -> machine) [target-updater! : (machine SlotValue -> Void)
(get-target-updater (AssignPrimOpStatement-target stmt))]) (get-target-updater (AssignPrimOpStatement-target stmt))])
(cond (cond
[(GetCompiledProcedureEntry? op) [(GetCompiledProcedureEntry? op)
(let: ([a-proc : SlotValue (machine-proc m)]) (let: ([a-proc : SlotValue (machine-proc m)])
(cond (cond
[(closure? a-proc) [(closure? a-proc)
(target-updater m (closure-label a-proc))] (target-updater! m (closure-label a-proc))]
[else [else
(error 'get-compiled-procedure-entry)]))] (error 'get-compiled-procedure-entry)]))]
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(target-updater m (make-closure (MakeCompiledProcedure-label op) (target-updater! m (make-closure (MakeCompiledProcedure-label op)
(MakeCompiledProcedure-arity op) (MakeCompiledProcedure-arity op)
(map (lambda: ([r : EnvReference]) (map (lambda: ([r : EnvReference])
(lookup-env-reference m r)) (lookup-env-reference m r))
@ -244,13 +237,15 @@
(ApplyPrimitiveProcedure-arity op)))]) (ApplyPrimitiveProcedure-arity op)))])
(cond (cond
[(primitive-proc? prim) [(primitive-proc? prim)
(target-updater m (ensure-primitive-value (apply (primitive-proc-f prim) args)))] (target-updater! m (ensure-primitive-value (apply (primitive-proc-f prim)
m
(ApplyPrimitiveProcedure-label op)
args)))]
[else [else
(error 'apply-primitive-procedure)]))] (error 'apply-primitive-procedure)]))]
[(GetControlStackLabel? op) [(GetControlStackLabel? op)
(target-updater m (frame-return (first (machine-control m))))]))) (target-updater! m (frame-return (first (machine-control m))))])))
@ -375,33 +370,29 @@
(: val-update (machine SlotValue -> machine)) (: val-update! (machine SlotValue -> Void))
(define (val-update m v) (define (val-update! m v)
(match m (set-machine-val! m v))
[(struct machine (val proc env control pc text
stack-size))
(make-machine v proc env control pc text stack-size)]))
(: proc-update (machine SlotValue -> machine))
(define (proc-update m v)
(match m
[(struct machine (val proc env control pc text
stack-size))
(make-machine val v env control pc text stack-size)]))
(: env-push (machine SlotValue -> machine)) (: proc-update! (machine SlotValue -> Void))
(define (env-push m v) (define (proc-update! m v)
(set-machine-proc! m v))
(: env-push! (machine SlotValue -> Void))
(define (env-push! m v)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(make-machine val proc (cons v env) control pc text (set-machine-env! m (cons v env))
(add1 stack-size))])) (set-machine-stack-size! m (add1 stack-size))]))
(: env-push-many (machine (Listof SlotValue) -> machine)) (: env-push-many! (machine (Listof SlotValue) -> Void))
(define (env-push-many m vs) (define (env-push-many! m vs)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(make-machine val proc (append vs env) control pc text (set-machine-env! m (append vs env))
(+ stack-size (length vs)))])) (set-machine-stack-size! m (+ stack-size (length vs)))]))
(: env-ref (machine Natural -> SlotValue)) (: env-ref (machine Natural -> SlotValue))
@ -410,11 +401,12 @@
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(list-ref env i)])) (list-ref env i)]))
(: env-mutate (machine Natural SlotValue -> machine)) (: env-mutate! (machine Natural SlotValue -> Void))
(define (env-mutate m i v) (define (env-mutate! m i v)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(make-machine val proc (list-replace env i v) control pc text stack-size)])) (set-machine-env! m (list-replace env i v))]))
(: list-replace (All (A) (Listof A) Natural A -> (Listof A))) (: list-replace (All (A) (Listof A) Natural A -> (Listof A)))
(define (list-replace l i v) (define (list-replace l i v)
@ -426,44 +418,44 @@
(list-replace (rest l) (sub1 i) v))])) (list-replace (rest l) (sub1 i) v))]))
(: env-pop (machine Natural Natural -> machine)) (: env-pop! (machine Natural Natural -> Void))
(define (env-pop m n skip) (define (env-pop! m n skip)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(make-machine val proc (append (take env skip) (set-machine-env! m (append (take env skip)
(drop env (+ skip n))) (drop env (+ skip n))))
control pc text (set-machine-stack-size! m (ensure-natural (- stack-size n)))]))
(ensure-natural (- stack-size n)))]))
(: control-push! (machine frame -> Void))
(: control-push (machine frame -> machine)) (define (control-push! m a-frame)
(define (control-push m a-frame)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(make-machine val proc env (cons a-frame control) pc text (set-machine-control! m (cons a-frame control))]))
stack-size)]))
(: control-pop (machine -> (values machine Symbol))) (: control-pop! (machine -> Symbol))
(define (control-pop m) (define (control-pop! m)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(values (make-machine val proc env (rest control) pc text stack-size) (begin
(frame-return (first control)))])) (set-machine-control! m (rest control))
(frame-return (first control)))]))
(: increment-pc (machine -> machine))
(define (increment-pc m)
(match m
[(struct machine (val proc env control pc text stack-size))
(make-machine val proc env control (add1 pc) text stack-size)]))
(: jump (machine Symbol -> machine)) (: increment-pc! (machine -> Void))
(define (increment-pc! m)
(set-machine-pc! m (add1 (machine-pc m))))
(: jump! (machine Symbol -> Void))
;; Jumps directly to the instruction at the given label. ;; Jumps directly to the instruction at the given label.
(define (jump m l) (define (jump! m l)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(struct machine (val proc env control pc text stack-size))
(make-machine val proc env control (vector-find text l) text stack-size)])) (set-machine-pc! m (vector-find text l))]))
(: vector-find (All (A) (Vectorof A) A -> Natural)) (: vector-find (All (A) (Vectorof A) A -> Natural))

6
test-compiler.rkt
View File

@ -57,8 +57,7 @@
#:stack-limit (stack-limit false) #:stack-limit (stack-limit false)
#:control-limit (control-limit false)) #:control-limit (control-limit false))
(let loop ([m m] (let loop ([steps 0])
[steps 0])
(when debug? (when debug?
(when (can-step? m) (when (can-step? m)
(printf "|env|=~s, |control|=~s, instruction=~s\n" (printf "|env|=~s, |control|=~s, instruction=~s\n"
@ -75,7 +74,8 @@
(cond (cond
[(can-step? m) [(can-step? m)
(loop (step m) (add1 steps))] (step! m)
(loop (add1 steps))]
[else [else
(values m steps)]))) (values m steps)])))

22
test-simulator.rkt
View File

@ -14,7 +14,7 @@
(begin (begin
(printf "Running ~s ..." (syntax->datum #'stx)) (printf "Running ~s ..." (syntax->datum #'stx))
(let ([results actual]) (let ([results actual])
(unless (equal? actual exp) (unless (equal? results exp)
(raise-syntax-error #f (format "Expected ~s, got ~s" exp results) (raise-syntax-error #f (format "Expected ~s, got ~s" exp results)
#'stx))) #'stx)))
(printf "ok\n\n"))))])) (printf "ok\n\n"))))]))
@ -26,7 +26,8 @@
[(= n 0) [(= n 0)
m] m]
[else [else
(step-n (step m) (sub1 n))])) (step! m)
(step-n m (sub1 n))]))
;; run: machine -> machine ;; run: machine -> machine
@ -34,7 +35,8 @@
(define (run m) (define (run m)
(cond (cond
[(can-step? m) [(can-step? m)
(run (step m))] (step! m)
(run m)]
[else [else
m])) m]))
@ -43,21 +45,23 @@
(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello))))]) (let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello))))])
(test (machine-pc (step-n m 0)) 0) (test (machine-pc (step-n m 0)) 0)
(test (machine-pc (step-n m 1)) 1) (test (machine-pc (step-n m 1)) 1)
(test (machine-pc (step-n m 2)) 2) (test (machine-pc (step-n m 1)) 2)
(test (machine-pc (step-n m 3)) 1) (test (machine-pc (step-n m 1)) 1)
(test (machine-pc (step-n m 4)) 2) (test (machine-pc (step-n m 1)) 2)
(test (machine-pc (step-n m 5)) 1)) (test (machine-pc (step-n m 1)) 1))
;; Assigning to val ;; Assigning to val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))))]) (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))))])
(test (machine-val m) (make-undefined)) (test (machine-val m) (make-undefined))
(test (machine-val (step m)) 42)) (step! m)
(test (machine-val m) 42))
;; Assigning to proc ;; Assigning to proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42))))]) (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42))))])
(test (machine-proc m) (make-undefined)) (test (machine-proc m) (make-undefined))
(test (machine-proc (step m)) 42)) (step! m)
(test (machine-proc m) 42))
;; Assigning to a environment reference ;; Assigning to a environment reference