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

Merge remote branch 'origin/master'

Browse Source
This commit is contained in:
Danny Yoo 2011-05-22 20:33:41 -04:00
commit 8a7971e19c
16 changed files with 264 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
bootstrapped-primitives.rkt
View File

@ -4,11 +4,13 @@
"il-structs.rkt"
"compiler.rkt"
"compiler-structs.rkt"
"typed-parse.rkt")
"typed-parse.rkt"
"where-is-collects.rkt")
(require/typed "parameters.rkt"
(current-defined-name (Parameterof (U Symbol LamPositionalName))))
(require/typed "parse-bytecode.rkt"
(parse-bytecode (Path -> Expression)))
@ -17,6 +19,17 @@
;; We'll hardcode the compilation of some Racket modules here.
(: hardcoded-modules-to-compile (Listof Path))
(define hardcoded-modules-to-compile
(list
(build-path collects-path "racket" "private" "modbeg.rkt")
))
;; The primitive code necessary to do call/cc
(: call/cc-label Symbol)
@ -85,7 +98,16 @@
(define (get-bootstrapping-code)
(append
;; module code
(apply append (map (lambda: ([p : Path])
(compile (parse-bytecode p)
'val
next-linkage/drop-multiple))
hardcoded-modules-to-compile))
;; Other primitives
(make-bootstrapped-primitive-code
'map
'(letrec ([map (lambda (f l)

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])

5
kernel-primitives.rkt
View File

@ -59,6 +59,11 @@
'values
'call-with-values
'apply
'printf
'map
'for-each
'current-print
))
(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)

40
parse-bytecode-5.1.1.rkt
View File

@ -30,9 +30,9 @@
(lambda (mpi relative-to)
(cond
[(eq? mpi #f)
'self]
(current-module-path)]
[(self-module-path-index? mpi)
'self]
(current-module-path)]
[else
(resolve-module-path-index mpi relative-to)]))))
@ -121,6 +121,11 @@
(parameterize ([seen-closures (make-hasheq)])
(let ([compilation-top (zo-parse in)])
(parse-top compilation-top)))]
[(compiled-expression? in)
(let ([op (open-output-bytes)])
(write in op)
(parse-bytecode (open-input-bytes (get-output-bytes op))))]
[(path? in)
(let*-values ([(normal-path) (normalize-path in)]
@ -144,8 +149,32 @@
(define (parse-top a-top)
(match a-top
[(struct compilation-top (max-let-depth prefix code))
(make-Top (parse-prefix prefix)
(parse-top-code code))]))
(maybe-fix-module-name
(make-Top (parse-prefix prefix)
(parse-top-code code)))]))
;; maybe-fix-module-name: expression -> expression
;; When we're compiling a module directly from memory, it doesn't have a file path.
;; We rewrite the ModuleName to its given name.
(define (maybe-fix-module-name exp)
(match exp
[(struct Top (top-prefix
(struct Module ((and name (? symbol?))
(struct ModuleName ('self 'self))
module-prefix
module-requires
module-code))))
(make-Top top-prefix
(make-Module name
(make-ModuleName name name) (current-module-path)
module-prefix
module-requires
module-code))]
[else
exp]))
(define (parse-prefix a-prefix)
@ -197,7 +226,8 @@
(make-ModuleName (rewrite-path resolved-path-name)
(normalize-path resolved-path-name))]
[else
(error 'wrap-module-name "Unable to resolve module path ~s" resolved-path-name)]))]))
(error 'wrap-module-name "Unable to resolve module path ~s."
resolved-path-name)]))]))

25
parse-bytecode.rkt
View File

@ -1,11 +1,32 @@
#lang racket/base
(require "version-case/version-case.rkt"
racket/file
(prefix-in whalesong: "version.rkt")
(for-syntax racket/base))
(version-case
[(version>= (version) "5.1.1")
(begin
(require "parse-bytecode-5.1.1.rkt")
(provide (all-from-out "parse-bytecode-5.1.1.rkt")))]
(provide (except-out (all-from-out "parse-bytecode-5.1.1.rkt")
parse-bytecode)))]
[else
(error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])
(error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])
(provide (rename-out [my-parse-bytecode parse-bytecode]))
(define (my-parse-bytecode x)
(cond
[(path? x)
(parse-bytecode x)]
[else
(parse-bytecode x)]))
(define cache-dir (build-path (find-system-path 'pref-dir)
"whalesong"
whalesong:version))
(unless (directory-exists? cache-dir)
(make-directory* cache-dir))

17
path-rewriter.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "parameters.rkt"
"where-is-collects.rkt"
racket/path
racket/contract
racket/list
@ -34,7 +35,7 @@
(string->symbol
(string-append "collects/"
(path->string
(find-relative-path collects a-path))))]
(find-relative-path collects-path a-path))))]
[(within-this-project-path? a-path)
(string->symbol
(string-append "whalesong/"
@ -49,24 +50,14 @@
#f])))
(define collects
(normalize-path
(let ([p (find-system-path 'collects-dir)])
(cond
[(relative-path? p)
(find-executable-path (find-system-path 'exec-file)
(find-system-path 'collects-dir))]
[else
p]))))
(define (within-root? a-path)
(within? (current-root-path) a-path))
(define (within-collects? a-path)
(within? collects a-path))
(within? collects-path a-path))
(define (within-this-project-path? a-path)

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)])

70
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)
@ -425,6 +453,9 @@
[(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)
@ -771,10 +802,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 +821,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

33
tests/test-compiler.rkt
View File

@ -3,7 +3,11 @@
(require "../simulator/simulator.rkt"
"../simulator/simulator-structs.rkt"
"../simulator/simulator-helpers.rkt"
"test-helpers.rkt")
"../parameters.rkt"
"test-helpers.rkt"
racket/runtime-path)
(define-runtime-path this-test-path ".")
@ -54,7 +58,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 +81,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
@ -1326,12 +1339,20 @@
#:with-bootstrapping? #t)
(parameterize ([current-module-path (build-path this-test-path "foo.rkt")])
(test '(module foo racket/base
(printf "hello world"))
(make-undefined)
#:as-main-module 'whalesong/tests/foo.rkt
#:with-bootstrapping? #t))
;; begin0 is still broken.
#;(test '(letrec ([f (lambda (x)
(test '(letrec ([f (lambda (x)
(if (= x 0)
0
(+ x (f (sub1 x)))))])
@ -1341,14 +1362,14 @@
#;(test '(let () (define (f x y z)
(test '(let () (define (f x y z)
(values y x z))
(call-with-values (lambda () (f 3 1 4))
(lambda args (list args))))
'((1 3 4))
#:with-bootstrapping? #t)
#;(test '(let () (define (f x y z)
(test '(let () (define (f x y z)
(begin0 (values y x z)
(display "")))
(call-with-values (lambda () (f 3 1 4))

28
tests/test-parse-bytecode.rkt
View File

@ -3,12 +3,15 @@
(require compiler/zo-parse
rackunit
racket/match
racket/path
"../parameters.rkt"
"../parse-bytecode.rkt"
"../lexical-structs.rkt"
"../expression-structs.rkt"
racket/runtime-path
(for-syntax racket/base))
(define-runtime-path this-test-path ".")
(define (run-zo-parse stx)
(parameterize ([current-namespace (make-base-namespace)]
@ -398,7 +401,30 @@
(#%provide f))))
(check-true
(parameterize ([current-root-path this-test-path]
[current-module-path (build-path this-test-path "foo.rkt")])
(check-true
(match (run-my-parse #'(module foo racket/base))
[(struct Top ((? Prefix?)
(struct Module ('foo
(struct ModuleName
('whalesong/tests/foo.rkt
(? (lambda (p)
(and (path? p)
(equal? (normalize-path p)
(normalize-path
(build-path this-test-path "foo.rkt"))))))))
(struct Prefix (list))
(list (struct ModuleName ('collects/racket/base.rkt
_)))
(struct Splice ('()))))))
#t]
[else
#f])))
#;(check-true
(match (parameterize ([current-root-path (build-path "/blah")]
[current-module-path (build-path "/blah" "foo" "bar.rkt")])
(run-my-parse '(module foo '#%kernel

4
version.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/racket/base
(provide version)
(: version String)
(define version "1.0")

18
where-is-collects.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang typed/racket/base
(require/typed racket/path
(normalize-path (Path -> Path)))
(require/typed typed/racket/base
(relative-path? (Any -> Boolean))
(find-executable-path (Path Path -> Path)))
(provide collects-path)
(define collects-path
(normalize-path
(let ([p (find-system-path 'collects-dir)])
(cond
[(relative-path? p)
(find-executable-path (find-system-path 'exec-file)
(find-system-path 'collects-dir))]
[else
p]))))