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

introducing prompts

Browse Source
This commit is contained in:
Danny Yoo 2011-04-01 18:08:29 -04:00
parent 4c07e59b83
commit 589731fc6f
7 changed files with 138 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compile.rkt
View File

@ -308,14 +308,16 @@
linkage
cenv
(append-instruction-sequences
#;(make-instruction-sequence `(,(make-PushPrompt)))
(make-instruction-sequence `(,(make-PushControlFrame/Prompt
default-continuation-prompt-tag)))
(compile (first-exp seq) cenv target next-linkage)
#;(make-instruction-sequence `(,(make-PushPrompt)))))]
(make-instruction-sequence `(,(make-PopControlFrame)))))]
[else
(append-instruction-sequences
#;(make-instruction-sequence `(,(make-PushPrompt)))
(make-instruction-sequence `(,(make-PushControlFrame/Prompt
(make-DefaultContinuationPromptTag))))
(compile (first-exp seq) cenv target next-linkage)
#;(make-instruction-sequence `(,(make-PushPrompt)))
(make-instruction-sequence `(,(make-PopControlFrame)))
(compile-splice (rest-exps seq) cenv target linkage))]))

17
il-structs.rkt
View File

@ -66,6 +66,7 @@
PopEnvironment
PushEnvironment
PushControlFrame
PushControlFrame/Prompt
PopControlFrame))
(define-type Statement (U UnlabeledStatement
@ -98,6 +99,19 @@
(define-struct: PushControlFrame ([label : Symbol])
#:transparent)
(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
;; TODO: add handler and arguments
)
#:transparent)
(define-struct: DefaultContinuationPromptTag ()
#:transparent)
(define default-continuation-prompt-tag
(make-DefaultContinuationPromptTag))
(define-struct: GotoStatement ([target : (U Label Reg)])
#:transparent)
@ -326,3 +340,6 @@
[stmts : (Listof UnlabeledStatement)])
#:transparent)
(define-predicate OpArg? OpArg)

8
simulator-helpers.rkt
View File

@ -28,7 +28,7 @@
v]
[(null? v)
v]
[(void? v)
[(VoidValue? v)
v]
[(MutablePair? v)
v]
@ -68,8 +68,8 @@
v]
[(null? v)
v]
[(void? v)
v]
[(VoidValue? v)
(void)]
[(undefined? v)
(letrec ([x x]) x)]
[(primitive-proc? v)
@ -96,7 +96,7 @@
[(null? v)
v]
[(void? v)
v]
the-void-value]
[(eq? v (letrec ([x x]) x))
(make-undefined)]
[(procedure? v)

34
simulator-primitives.rkt
View File

@ -81,7 +81,8 @@
(vector-ref x 0)))
(define my-set-box! (lambda (x v)
(vector-set! x 0 v)))
(vector-set! x 0 v)
the-void-value))
(define my-vector->list (lambda (v)
(apply my-list (vector->list v))))
@ -98,15 +99,31 @@
(define my-set-car! (lambda (p v)
(set-MutablePair-h! p v)))
(set-MutablePair-h! p v)
the-void-value))
(define my-set-cdr! (lambda (p v)
(set-MutablePair-t! 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 lookup-primitive (make-lookup #:functions (+ - * / = < <= > >=
sub1
display newline displayln
not
null?
eq?
@ -114,12 +131,13 @@
sub1
zero?
abs
void
(my-void void)
quotient
remainder
display
displayln
newline
(my-display display)
(my-displayln displayln)
(my-newline newline)
symbol->string
string-append

28
simulator-structs.rkt
View File

@ -7,7 +7,7 @@
(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
Null Void
Null VoidValue
undefined
primitive-proc
@ -24,6 +24,10 @@
CapturedEnvironment))
(define-struct: VoidValue () #:transparent)
(define the-void-value (make-VoidValue))
(define-struct: MutablePair ([h : PrimitiveValue]
[t : PrimitiveValue])
#:mutable #:transparent)
@ -51,12 +55,24 @@
#:mutable)
(define-struct: frame ([return : Symbol]
;; The procedure being called. Used to optimize self-application
[proc : (U closure #f)]
;; TODO: add continuation marks
)
(define-type frame (U CallFrame PromptFrame))
(define-struct: CallFrame ([return : Symbol]
;; The procedure being called. Used to optimize self-application
[proc : (U closure #f)]
;; TODO: add continuation marks
)
#:transparent)
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue])
#:transparent)
(define-struct: ContinuationPromptTagValue ([name : Symbol])
#:transparent)
(define default-continuation-prompt-tag-value
(make-ContinuationPromptTagValue 'default-continuation-prompt))
(define-struct: toplevel ([names : (Listof (U #f Symbol ModuleVariable))]
[vals : (Listof PrimitiveValue)])

91
simulator.rkt
View File

@ -83,29 +83,32 @@
(: step! (machine -> 'ok))
;; Take one simulation step.
(define (step! m)
(let: ([i : Statement (current-instruction m)])
(cond
[(symbol? 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)]
[(PopControlFrame? i)
(step-pop-control-frame! m i)]))
(increment-pc! m))
(let*: ([i : Statement (current-instruction m)]
[result : 'ok
(cond
[(symbol? 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)])])
(increment-pc! m)))
@ -149,8 +152,20 @@
(: step-push-control-frame! (machine PushControlFrame -> 'ok))
(define (step-push-control-frame! m stmt)
(control-push! m (make-frame (PushControlFrame-label stmt)
(ensure-closure-or-false (machine-proc m)))))
(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))])))))
(: step-pop-control-frame! (machine PopControlFrame -> 'ok))
(define (step-pop-control-frame! m stmt)
@ -325,7 +340,7 @@
(error 'apply-primitive-procedure)]))]
[(GetControlStackLabel? op)
(target-updater! m (frame-return (first (machine-control m))))]
(target-updater! m (CallFrame-return (ensure-CallFrame (first (machine-control m)))))]
[(CaptureEnvironment? op)
(target-updater! m (make-CapturedEnvironment (drop (machine-env m)
@ -381,7 +396,8 @@
(let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals])
(cond [(empty? rand-vals)
null]
[(make-MutablePair (first rand-vals)
[else
(make-MutablePair (first rand-vals)
(loop (rest rand-vals)))]))]
[(null?)
(null? (first rand-vals))]
@ -453,11 +469,12 @@
(let: ([v : SlotValue
(list-ref (machine-env m) (EnvWholePrefixReference-depth an-oparg))])
(cond
[(PrimitiveValue? v)
(error 'evaluate-oparg "Internal error: primitive value at depth ~s"
(EnvWholePrefixReference-depth an-oparg))]
[(toplevel? v)
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)))
@ -472,6 +489,18 @@
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.

6
test-compiler.rkt
View File

@ -443,7 +443,7 @@
33644764876431783266621612005107543310302148460680063906564769974680081442166662368155595513633734025582065332680836159373734790483865268263040892463056431887354544369559827491606602099884183933864652731300088830269235673613135117579297437854413752130520504347701602264758318906527890855154366159582987279682987510631200575428783453215515103870818298969791613127856265033195487140214287532698187962046936097879900350962302291026368131493195275630227837628441540360584402572114334961180023091208287046088923962328835461505776583271252546093591128203925285393434620904245248929403901706233888991085841065183173360437470737908552631764325733993712871937587746897479926305837065742830161637408969178426378624212835258112820516370298089332099905707920064367426202389783111470054074998459250360633560933883831923386783056136435351892133279732908133732642652633989763922723407882928177953580570993691049175470808931841056146322338217465637321248226383092103297701648054726243842374862411453093812206564914032751086643394517512161526545361333111314042436854805106765843493523836959653428071768775328348234345557366719731392746273629108210679280784718035329131176778924659089938635459327894523777674406192240337638674004021330343297496902028328145933418826817683893072003634795623117103101291953169794607632737589253530772552375943788434504067715555779056450443016640119462580972216729758615026968443146952034614932291105970676243268515992834709891284706740862008587135016260312071903172086094081298321581077282076353186624611278245537208532365305775956430072517744315051539600905168603220349163222640885248852433158051534849622434848299380905070483482449327453732624567755879089187190803662058009594743150052402532709746995318770724376825907419939632265984147498193609285223945039707165443156421328157688908058783183404917434556270520223564846495196112460268313970975069382648706613264507665074611512677522748621598642530711298441182622661057163515069260029861704945425047491378115154139941550671256271197133252763631939606902895650288268608362241082050562430701794976171121233066073310059947366875
#:stack-limit 10
#:control-limit 1)
#:control-limit 2)
@ -577,7 +577,7 @@
(sum-iter 300 0))
45150
#:stack-limit 8
#:control-limit 1)
#:control-limit 2)
(test '(let ([x 16])
@ -782,7 +782,7 @@
(sum-iter 300 0))
45150
#:stack-limit 10
#:control-limit 1)
#:control-limit 2)