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

introducing prompts in the simulator

Browse Source
This commit is contained in:
Danny Yoo 2011-04-01 18:39:34 -04:00
parent 589731fc6f
commit 8c3a9c5136
6 changed files with 93 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
bootstrapped-primitives.rkt
View File

@ -34,7 +34,7 @@
;; Next, capture the envrionment and the current continuation closure,.
,(make-PushEnvironment 2 #f)
,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0))
(make-CaptureControl 0 default-continuation-prompt-tag))
,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3))
@ -52,12 +52,13 @@
'val
return-linkage)
;; The code for the continuation coe follows. It's supposed to
;; The code for the continuation code follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump.
(make-instruction-sequence `(,call/cc-closure-entry
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PerformStatement (make-InstallClosureValues!))
,(make-PerformStatement (make-RestoreControl!))
,(make-PerformStatement
(make-RestoreControl! default-continuation-prompt-tag))
,(make-PerformStatement (make-RestoreEnvironment!))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)

22
compile.rkt
View File

@ -23,14 +23,20 @@
(define (-compile exp target linkage)
(let ([after-lam-bodies (make-label 'afterLamBodies)])
(statements
(append-instruction-sequences (make-instruction-sequence
`(,(make-GotoStatement (make-Label after-lam-bodies))))
(compile-lambda-bodies (collect-all-lams exp))
after-lam-bodies
(compile exp
'()
target
linkage)))))
(end-with-linkage
linkage '()
(append-instruction-sequences (make-instruction-sequence
`(,(make-GotoStatement (make-Label after-lam-bodies))))
(compile-lambda-bodies (collect-all-lams exp))
after-lam-bodies
(make-instruction-sequence
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag)))
(compile exp
'()
target
next-linkage)
(make-instruction-sequence
`(,(make-PopControlFrame))))))))
(define-struct: lam+cenv ([lam : Lam]
[cenv : CompileTimeEnvironment]))

5
il-structs.rkt
View File

@ -198,7 +198,8 @@
(define-struct: CaptureEnvironment ([skip : Natural]))
;; Capture the control stack, skipping skip frames.
(define-struct: CaptureControl ([skip : Natural]))
(define-struct: CaptureControl ([skip : Natural]
[tag : (U DefaultContinuationPromptTag OpArg)]))
@ -245,7 +246,7 @@
#:transparent)
;; Changes over the control located at the given argument from the structure in env[1]
(define-struct: RestoreControl! ())
(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]))
;; Changes over the environment located at the given argument from the structure in env[0]
(define-struct: RestoreEnvironment! ())

2
simulator-primitives.rkt
View File

@ -1,7 +1,5 @@
#lang racket/base
(require "simulator-structs.rkt"
"compile.rkt"
"bootstrapped-primitives.rkt"
racket/math
(for-syntax racket/base))

73
simulator.rkt
View File

@ -260,8 +260,18 @@
'ok)]
[(RestoreControl!? op)
(set-machine-control! m (CapturedControl-frames (ensure-CapturedControl (env-ref m 0))))
'ok]
(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 (append
(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))))
@ -346,8 +356,8 @@
(target-updater! m (make-CapturedEnvironment (drop (machine-env m)
(CaptureEnvironment-skip op))))]
[(CaptureControl? op)
(target-updater! m (make-CapturedControl (drop (machine-control m)
(CaptureControl-skip op))))]
(target-updater! m (evaluate-continuation-capture m op))]
[(MakeBoxedEnvironmentValue? op)
(target-updater! m (box (ensure-primitive-value
(env-ref m (MakeBoxedEnvironmentValue-depth op)))))]
@ -356,6 +366,61 @@
(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)]

6
test-compiler.rkt
View File

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