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

trying to get module invokation working under tests

Browse Source
This commit is contained in:
Danny Yoo 2011-05-22 18:50:14 -04:00
parent 125eed5924
commit ac678fba7b
9 changed files with 113 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler.rkt
View File

@ -382,7 +382,7 @@
(make-IsModuleInvoked a-module-name))
already-loaded)
,(make-PushControlFrame/Call on-return)
,(make-GotoStatement (make-ModuleEntry a-module-name))
,(make-GotoStatement (ModuleEntry a-module-name))
,on-return-multiple
,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount)
(make-Const 1))

5
il-structs.rkt
View File

@ -204,7 +204,10 @@
(define-struct: GotoStatement ([target : OpArg])
(define-struct: GotoStatement ([target : (U Label
Reg
ModuleEntry
CompiledProcedureEntry)])
#:transparent)
(define-struct: PerformStatement ([op : PrimitiveCommand])

1
kernel-primitives.rkt
View File

@ -59,6 +59,7 @@
'values
'call-with-values
'apply
'printf
))
(define-predicate KernelPrimitiveName? KernelPrimitiveName)

5
lang/kernel.rkt
View File

@ -63,12 +63,13 @@
#%app
#%top-interaction
#%top
define
module
define
define-values
let-values
let*-values
define-struct
if
if
cond
else
case

36
package.rkt
View File

@ -6,6 +6,7 @@
"language-namespace.rkt"
"il-structs.rkt"
"bootstrapped-primitives.rkt"
"get-module-bytecode.rkt"
"get-dependencies.rkt"
"js-assembler/assemble.rkt"
"js-assembler/get-runtime.rkt"
@ -23,34 +24,21 @@
(define-runtime-path kernel-language-path
"lang/kernel.rkt")
;; Use Racket's compiler, and then parse the resulting bytecode
;; to our own AST structures.
(define (parse stx)
(parameterize ([current-namespace (lookup-language-namespace
`(file ,(path->string kernel-language-path))
#;'racket/base)]
;; We want to disable some optimizations for the moment.
;; See: http://docs.racket-lang.org/drracket/module.html
[compile-context-preservation-enabled #t])
(let ([bc (racket:compile stx)]
[op (open-output-bytes)])
(write bc op)
(parse-bytecode
(open-input-bytes (get-output-bytes op))))))
;; package: s-expression output-port -> void
(define (package source-code op)
(fprintf op "var invoke = ")
(assemble/write-invoke (append (get-bootstrapping-code)
(compile (parse source-code)
'val
next-linkage/drop-multiple))
op)
(fprintf op ";\n"))
(let ([source-code-op (open-output-bytes)])
(write source-code source-code-op)
(let ([source-code-ip (open-input-bytes (get-output-bytes source-code-op))])
(fprintf op "var invoke = ")
(assemble/write-invoke (append (get-bootstrapping-code)
(compile (parse-bytecode
(open-input-bytes (get-module-bytecode source-code-ip)))
'val
next-linkage/drop-multiple))
op)
(fprintf op ";\n"))))
(define (package-anonymous source-code op)

12
simulator/simulator-primitives.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "simulator-structs.rkt"
"../il-structs.rkt"
"simulator-helpers.rkt"
racket/math
racket/list
(for-syntax racket/base))
@ -170,6 +171,11 @@
(error 'member "not a list: ~s" l)]))))
(define my-printf (lambda (fmt args)
(apply printf fmt (map (lambda (x)
(PrimitiveValue->racket x))
args))))
(define current-continuation-marks
@ -258,11 +264,11 @@
equal?
symbol?
symbol?)
(my-printf printf)
)
#:constants (null pi e
current-continuation-marks
continuation-mark-set->list)))

12
simulator/simulator-structs.rkt
View File

@ -7,6 +7,14 @@
"../lexical-structs.rkt")
;; A special "label" in the system that causes evaluation to stop.
(define-struct: halt ())
(define HALT (make-halt))
(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
Null VoidValue
undefined
@ -79,7 +87,7 @@
#:transparent)
(define-struct: CallFrame ([return : LinkedLabel]
(define-struct: CallFrame ([return : (U LinkedLabel halt)]
;; The procedure being called. Used to optimize self-application
[proc : (U closure #f)]
;; TODO: add continuation marks
@ -89,7 +97,7 @@
#:mutable) ;; mutable because we want to allow mutation of proc.
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
[return : LinkedLabel]
[return : (U LinkedLabel halt)]
[env-depth : Natural]
[temps : (HashTable Symbol PrimitiveValue)]
[marks : (HashTable PrimitiveValue PrimitiveValue)])

67
simulator/simulator.rkt
View File

@ -27,14 +27,22 @@
[racket->PrimitiveValue (Any -> PrimitiveValue)])
(provide new-machine can-step? step! current-instruction
(provide new-machine
can-step?
step!
current-instruction
current-simulated-output-port
machine-control-size)
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
@ -45,11 +53,12 @@
[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])])
(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)
@ -79,6 +88,25 @@
(: 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)
@ -771,10 +799,17 @@
(error 'GetControlStackLabel)]
[(PromptFrame? frame)
(let ([label (PromptFrame-return frame)])
(LinkedLabel-label label))]
(cond [(halt? label)
end-of-program-text]
[else
(LinkedLabel-label label)]))]
[(CallFrame? frame)
(let ([label (CallFrame-return frame)])
(LinkedLabel-label label))]))]
(cond
[(halt? label)
end-of-program-text]
[else
(LinkedLabel-label label)]))]))]
[(ControlStackLabel/MultipleValueReturn? an-oparg)
(let ([frame (ensure-frame (first (machine-control m)))])
@ -783,11 +818,19 @@
(error 'GetControlStackLabel/MultipleValueReturn)]
[(PromptFrame? frame)
(let ([label (PromptFrame-return frame)])
(LinkedLabel-linked-to label))]
(cond
[(halt? label)
end-of-program-text]
[else
(LinkedLabel-linked-to label)]))]
[(CallFrame? frame)
(let ([label (CallFrame-return frame)])
(LinkedLabel-linked-to label))]))]
(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

20
tests/test-compiler.rkt
View File

@ -54,7 +54,8 @@
#:debug? (debug? false)
#:stack-limit (stack-limit false)
#:control-limit (control-limit false)
#:with-bootstrapping? (with-bootstrapping? false))
#:with-bootstrapping? (with-bootstrapping? false)
#:as-main-module (as-main-module #f))
(let ([m (new-machine (run-compiler code) with-bootstrapping?)])
(let loop ([steps 0])
(when debug?
@ -76,7 +77,15 @@
(step! m)
(loop (add1 steps))]
[else
(values m steps)]))))
(cond
[as-main-module
;; Set the pc to the module's entry point
;; Set the return point to halt on exit.
(invoke-module-as-main m as-main-module)
(set! as-main-module #f)
(loop (add1 steps))]
[else
(values m steps)])]))))
;; Atomic expressions
@ -1327,6 +1336,13 @@
(test '(module foo racket/base
(printf "hello world"))
(make-undefined)
#:as-main-module 'foo)
;; begin0 is still broken.