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-06-01 13:09:32 -04:00
commit 5445ae1afc
23 changed files with 327 additions and 509 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -9,6 +9,9 @@ test-all:
raco make -v --disable-inline tests/test-all.rkt raco make -v --disable-inline tests/test-all.rkt
racket tests/test-all.rkt racket tests/test-all.rkt
test-browser-evaluate:
raco make -v --disable-inline tests/test-browser-evaluate.rkt
racket tests/test-browser-evaluate.rkt
test-compiler: test-compiler:
raco make -v --disable-inline tests/test-compiler.rkt raco make -v --disable-inline tests/test-compiler.rkt

12
NOTES
View File

@ -584,3 +584,15 @@ Nan, INF Numbers, Regular expressions, keywords, byte strings,
character literals character literals
Missing #%paramz module Missing #%paramz module
----------------------------------------------------------------------
What needs to be done next?
benchmarks
being able to write modules in javascript
being able to bundle external resources (like images)

3
compiler/analyzer-structs.rkt
View File

@ -22,7 +22,8 @@
(U '? ;; no knowledge (U '? ;; no knowledge
Prefix ;; placeholder: necessary since the toplevel lives in the environment too Prefix ;; placeholder: necessary since the toplevel lives in the environment too
StaticallyKnownLam ;; The value is a known lam StaticallyKnownLam ;; The value is a known lam
ModuleVariable ;; The value is a known module variable ModuleVariable ;; The value is a variable from a module
PrimitiveKernelValue
Const Const
)) ))

401
compiler/analyzer.rkt
View File

@ -1,401 +0,0 @@
#lang typed/racket/base
(provide (rename-out [-analyze analyze])
analysis-lookup
analysis-alias!)
(require "analyzer-structs.rkt"
"expression-structs.rkt"
"il-structs.rkt"
"lexical-structs.rkt"
racket/match
racket/list)
(: current-expression-map
(Parameterof (HashTable Expression CompileTimeEnvironmentEntry)))
(define current-expression-map (make-parameter
((inst make-hasheq Expression
CompileTimeEnvironmentEntry))))
(: -analyze (Expression -> Analysis))
(define (-analyze exp)
(parameterize ([current-expression-map
((inst make-hasheq Expression CompileTimeEnvironmentEntry))])
(analyze exp '())
(make-Analysis (current-expression-map))))
(: analyze (Expression CompileTimeEnvironment -> 'ok))
;; Finds all the lambdas in the expression.
(define (analyze exp cenv)
(cond
[(Top? exp)
(analyze-Top exp cenv)]
[(Module? exp)
(analyze-Module exp cenv)]
[(Constant? exp)
(analyze-Constant exp cenv)]
[(LocalRef? exp)
(analyze-LocalRef exp cenv)]
[(ToplevelRef? exp)
(analyze-ToplevelRef exp cenv)]
[(ToplevelSet? exp)
(analyze-ToplevelSet exp cenv)]
[(Branch? exp)
(analyze-Branch exp cenv)]
[(Lam? exp)
(analyze-Lam exp cenv)]
[(CaseLam? exp)
(analyze-CaseLam exp cenv)]
[(EmptyClosureReference? exp)
(analyze-EmptyClosureReference exp cenv)]
[(Seq? exp)
(analyze-Seq exp cenv)]
[(Splice? exp)
(analyze-Splice exp cenv)]
[(Begin0? exp)
(analyze-Begin0 exp cenv)]
[(App? exp)
(analyze-App exp cenv)]
[(Let1? exp)
(analyze-Let1 exp cenv)]
[(LetVoid? exp)
(analyze-LetVoid exp cenv)]
[(InstallValue? exp)
(analyze-InstallValue exp cenv)]
[(BoxEnv? exp)
(analyze-BoxEnv exp cenv)]
[(LetRec? exp)
(analyze-LetRec exp cenv)]
[(WithContMark? exp)
(analyze-WithContMark exp cenv)]
[(ApplyValues? exp)
(analyze-ApplyValues exp cenv)]
[(DefValues? exp)
(analyze-DefValues exp cenv)]
[(PrimitiveKernelValue? exp)
(analyze-PrimitiveKernelValue exp cenv)]
[(VariableReference? exp)
(analyze-VariableReference exp cenv)]
[(Require? exp)
(analyze-Require exp cenv)]))
(: analyze-Top (Top CompileTimeEnvironment -> 'ok))
(define (analyze-Top exp cenv)
(match exp
[(struct Top (prefix code))
(analyze code (list prefix))]))
(: analyze-Module (Module CompileTimeEnvironment -> 'ok))
(define (analyze-Module exp cenv)
(match exp
[(struct Module (name path prefix requires code))
(analyze code (list prefix))]))
(: analyze-Constant (Constant CompileTimeEnvironment -> 'ok))
(define (analyze-Constant exp cenv)
'ok)
(: analyze-LocalRef (LocalRef CompileTimeEnvironment -> 'ok))
(define (analyze-LocalRef exp cenv)
(annotate exp (extract-static-knowledge exp cenv))
'ok)
(: analyze-ToplevelRef (ToplevelRef CompileTimeEnvironment -> 'ok))
(define (analyze-ToplevelRef exp cenv)
(annotate exp (extract-static-knowledge exp cenv))
'ok)
(: analyze-ToplevelSet (ToplevelSet CompileTimeEnvironment -> 'ok))
(define (analyze-ToplevelSet exp cenv)
(match exp
[(struct ToplevelSet (depth pos value))
(analyze value cenv)]))
(: analyze-Branch (Branch CompileTimeEnvironment -> 'ok))
(define (analyze-Branch exp cenv)
(match exp
[(struct Branch (test cons alter))
(analyze test cenv)
(analyze cons cenv)
(analyze alter cenv)]))
(: analyze-Lam (Lam CompileTimeEnvironment -> 'ok))
(define (analyze-Lam exp cenv)
(match exp
[(struct Lam (name num-parameters rest? body closure-map entry-label))
(analyze body (extract-lambda-body-cenv exp cenv))]))
(: extract-lambda-body-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
;; Given a Lam and the ambient environment, produces the compile time environment for the
;; body of the lambda.
(define (extract-lambda-body-cenv lam cenv)
(append (map (lambda: ([d : Natural])
(list-ref cenv d))
(Lam-closure-map lam))
(build-list (if (Lam-rest? lam)
(add1 (Lam-num-parameters lam))
(Lam-num-parameters lam))
(lambda: ([i : Natural]) '?))))
(: analyze-CaseLam (CaseLam CompileTimeEnvironment -> 'ok))
(define (analyze-CaseLam exp cenv)
(match exp
[(struct CaseLam (name clauses entry-label))
(for-each (lambda: ([c : Expression])
(analyze c cenv))
clauses)
'ok]))
(: analyze-EmptyClosureReference (EmptyClosureReference CompileTimeEnvironment -> 'ok))
(define (analyze-EmptyClosureReference exp cenv)
'ok)
(: analyze-Seq (Seq CompileTimeEnvironment -> 'ok))
(define (analyze-Seq exp cenv)
(match exp
[(struct Seq (actions))
(for-each (lambda: ([e : Expression])
(analyze e cenv))
actions)
'ok]))
(: analyze-Splice (Splice CompileTimeEnvironment -> 'ok))
(define (analyze-Splice exp cenv)
(match exp
[(struct Splice (actions))
(for-each (lambda: ([e : Expression])
(analyze e cenv))
actions)
'ok]))
(: analyze-Begin0 (Begin0 CompileTimeEnvironment -> 'ok))
(define (analyze-Begin0 exp cenv)
(match exp
[(struct Begin0 (actions))
(for-each (lambda: ([e : Expression])
(analyze e cenv))
actions)
'ok]))
(: analyze-App (App CompileTimeEnvironment -> 'ok))
(define (analyze-App exp cenv)
(match exp
[(struct App (operator operands))
(let ([extended-cenv (extend/unknowns cenv (length operands))])
(analyze operator extended-cenv)
(for-each (lambda: ([o : Expression])
(analyze o extended-cenv))
operands)
'ok)]))
(: analyze-Let1 (Let1 CompileTimeEnvironment -> 'ok))
(define (analyze-Let1 exp cenv)
(match exp
[(struct Let1 (rhs body))
(analyze rhs
(extend/unknowns cenv 1))
(analyze body
(cons (extract-static-knowledge
rhs
(extend/unknowns cenv 1))
cenv))]))
(: analyze-LetVoid (LetVoid CompileTimeEnvironment -> 'ok))
(define (analyze-LetVoid exp cenv)
(match exp
[(struct LetVoid (count body boxes?))
(analyze body (extend/unknowns cenv count))]))
(: analyze-InstallValue (InstallValue CompileTimeEnvironment -> 'ok))
(define (analyze-InstallValue exp cenv)
(match exp
[(struct InstallValue (count depth body box?))
(analyze body cenv)]))
(: analyze-BoxEnv (BoxEnv CompileTimeEnvironment -> 'ok))
(define (analyze-BoxEnv exp cenv)
(match exp
[(struct BoxEnv (depth body))
(analyze body cenv)]))
(: analyze-LetRec (LetRec CompileTimeEnvironment -> 'ok))
(define (analyze-LetRec exp cenv)
(match exp
[(struct LetRec (procs body))
(let* ([n (length procs)]
[extended-cenv
(append (map (lambda: ([p : Expression])
(extract-static-knowledge p cenv))
procs)
(drop cenv n))])
(for-each (lambda: ([p : Expression])
(analyze p extended-cenv))
procs)
(analyze body extended-cenv))]))
(: analyze-WithContMark (WithContMark CompileTimeEnvironment -> 'ok))
(define (analyze-WithContMark exp cenv)
(match exp
[(struct WithContMark (key value body))
(analyze key cenv)
(analyze value cenv)
(analyze body cenv)]))
(: analyze-ApplyValues (ApplyValues CompileTimeEnvironment -> 'ok))
(define (analyze-ApplyValues exp cenv)
(match exp
[(struct ApplyValues (proc args-expr))
(analyze args-expr cenv)
(analyze proc cenv)]))
(: analyze-DefValues (DefValues CompileTimeEnvironment -> 'ok))
(define (analyze-DefValues exp cenv)
(match exp
[(struct DefValues (ids rhs))
(analyze rhs cenv)]))
(: analyze-PrimitiveKernelValue (PrimitiveKernelValue CompileTimeEnvironment -> 'ok))
(define (analyze-PrimitiveKernelValue exp cenv)
'ok)
(: analyze-VariableReference (VariableReference CompileTimeEnvironment -> 'ok))
(define (analyze-VariableReference exp cenv)
'ok)
(: analyze-Require (Require CompileTimeEnvironment -> 'ok))
(define (analyze-Require exp cenv)
'ok)
(: annotate (Expression CompileTimeEnvironmentEntry -> 'ok))
;; Accumulate information about an expression into the map.
(define (annotate exp info)
(let ([my-map (current-expression-map)])
(hash-set! my-map exp info)
'ok))
(: extend/unknowns
(CompileTimeEnvironment Natural -> CompileTimeEnvironment))
(define (extend/unknowns cenv n)
(append (build-list n (lambda: ([i : Natural])
'?))
cenv))
(: extract-static-knowledge (Expression CompileTimeEnvironment ->
CompileTimeEnvironmentEntry))
;; Statically determines what we know about the expression, given the compile time environment.
;; We should do more here eventually, including things like type inference or flow analysis, so that
;; we can generate better code.
(define (extract-static-knowledge exp cenv)
(cond
[(Lam? exp)
(make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp)))]
[(and (LocalRef? exp) (not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))])
entry)]
[(ToplevelRef? exp)
(let: ([name : (U Symbol False GlobalBucket ModuleVariable)
(list-ref (Prefix-names
(ensure-prefix
(list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))])
(cond
[(ModuleVariable? name)
name]
[(GlobalBucket? name)
'?]
[else
'?]))]
[(Constant? exp)
(make-Const (Constant-v exp))]
[else
'?]))
(: analysis-lookup (Analysis Expression -> CompileTimeEnvironmentEntry))
(define (analysis-lookup an-analysis an-exp)
(cond
[(Lam? exp)
(make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp)))]
[(and (LocalRef? exp) (not (LocalRef-unbox? exp)))
(hash-ref (Analysis-ht an-analysis) an-exp '?)]
[(ToplevelRef? exp)
(hash-ref (Analysis-ht an-analysis) an-exp '?)]
[(Constant? exp)
(make-Const (Constant-v exp))]
[else
'?]))
(: analysis-alias! (Analysis Expression Expression -> Void))
(define (analysis-alias! an-analysis from to)
(hash-set! (Analysis-ht an-analysis) to
(analysis-lookup an-analysis from)))
(: ensure-prefix (Any -> Prefix))
(define (ensure-prefix x)
(if (Prefix? x)
x
(error 'ensure-prefix "Not a prefix: ~e" x)))

34
compiler/compiler.rkt
View File

@ -7,7 +7,7 @@
"kernel-primitives.rkt" "kernel-primitives.rkt"
"optimize-il.rkt" "optimize-il.rkt"
"analyzer-structs.rkt" "analyzer-structs.rkt"
"analyzer.rkt" #;"analyzer.rkt"
"../parameters.rkt" "../parameters.rkt"
"../sets.rkt" "../sets.rkt"
racket/match racket/match
@ -20,8 +20,8 @@
(: current-analysis (Parameterof Analysis)) #;(: current-analysis (Parameterof Analysis))
(define current-analysis (make-parameter (empty-analysis))) #;(define current-analysis (make-parameter (empty-analysis)))
@ -30,7 +30,7 @@
;; Note: the toplevel generates the lambda body streams at the head, and then the ;; Note: the toplevel generates the lambda body streams at the head, and then the
;; rest of the instruction stream. ;; rest of the instruction stream.
(define (-compile exp target linkage) (define (-compile exp target linkage)
(parameterize ([current-analysis (analyze exp)]) (parameterize (#;[current-analysis (analyze exp)])
(let* ([after-lam-bodies (make-label 'afterLamBodies)] (let* ([after-lam-bodies (make-label 'afterLamBodies)]
[before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)] [before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)]
[before-pop-prompt (make-LinkedLabel [before-pop-prompt (make-LinkedLabel
@ -60,6 +60,7 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Reg 'val))))))))))) `(,(make-AssignImmediateStatement target (make-Reg 'val)))))))))))
(define-struct: lam+cenv ([lam : (U Lam CaseLam)] (define-struct: lam+cenv ([lam : (U Lam CaseLam)]
[cenv : CompileTimeEnvironment])) [cenv : CompileTimeEnvironment]))
@ -338,12 +339,10 @@
(make-PerformStatement (make-MarkModuleInvoked! path)) (make-PerformStatement (make-MarkModuleInvoked! path))
;; Module body definition: ;; Module body definition:
;; 1. First invoke all the modules that this requires. ;; 1. First invoke all the modules that this requires.
#;(make-DebugPrint (make-Const "handling internal requires"))
(apply append-instruction-sequences (apply append-instruction-sequences
(map compile-module-invoke (Module-requires mod))) (map compile-module-invoke (Module-requires mod)))
;; 2. Next, evaluate the module body. ;; 2. Next, evaluate the module body.
#;(make-DebugPrint (make-Const (format "evaluating module body of ~s" path)))
(make-PerformStatement (make-ExtendEnvironment/Prefix! names)) (make-PerformStatement (make-ExtendEnvironment/Prefix! names))
(make-AssignImmediateStatement (make-ModulePrefixTarget path) (make-AssignImmediateStatement (make-ModulePrefixTarget path)
@ -354,14 +353,11 @@
'val 'val
next-linkage/drop-multiple) next-linkage/drop-multiple)
#;(make-DebugPrint (make-Const (format "About to clean up ~s" path)))
;; 3. Finally, cleanup and return. ;; 3. Finally, cleanup and return.
(make-PopEnvironment (make-Const 1) (make-Const 0)) (make-PopEnvironment (make-Const 1) (make-Const 0))
(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel))
(make-PopControlFrame) (make-PopControlFrame)
#;(make-DebugPrint (make-Const "Returning from module invokation."))
#;(make-DebugPrint (make-Reg 'proc))
(make-PerformStatement (make-FinalizeModuleInvokation! path)) (make-PerformStatement (make-FinalizeModuleInvokation! path))
(make-GotoStatement (make-Reg 'proc)) (make-GotoStatement (make-Reg 'proc))
@ -405,7 +401,6 @@
,(make-TestAndBranchStatement (make-TestTrue ,(make-TestAndBranchStatement (make-TestTrue
(make-IsModuleInvoked a-module-name)) (make-IsModuleInvoked a-module-name))
already-loaded) already-loaded)
#;,(make-DebugPrint (make-Const (format "entering module ~s" a-module-name)))
,(make-PushControlFrame/Call on-return) ,(make-PushControlFrame/Call on-return)
,(make-GotoStatement (ModuleEntry a-module-name)) ,(make-GotoStatement (ModuleEntry a-module-name))
,on-return-multiple ,on-return-multiple
@ -413,7 +408,6 @@
(make-Const 1)) (make-Const 1))
(make-Const 0)) (make-Const 0))
,on-return ,on-return
#;,(make-DebugPrint (make-Const (format "coming back from module ~s" a-module-name)))
,already-loaded)))])) ,already-loaded)))]))
@ -994,6 +988,13 @@
(cond (cond
[(eq? op-knowledge '?) [(eq? op-knowledge '?)
(default)] (default)]
[(PrimitiveKernelValue? op-knowledge)
(let ([id (PrimitiveKernelValue-id op-knowledge)])
(cond
[(KernelPrimitiveName/Inline? id)
(compile-kernel-primitive-application id exp cenv target linkage)]
[else
(default)]))]
[(ModuleVariable? op-knowledge) [(ModuleVariable? op-knowledge)
(cond (cond
[(symbol=? (ModuleLocator-name [(symbol=? (ModuleLocator-name
@ -1320,11 +1321,11 @@
(length (App-operands exp))) (length (App-operands exp)))
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-instruction-sequence (make-PerformStatement
`(,(make-PerformStatement
(make-RaiseArityMismatchError! (make-RaiseArityMismatchError!
(make-Reg 'proc)
(StaticallyKnownLam-arity static-knowledge) (StaticallyKnownLam-arity static-knowledge)
(make-Const (length (App-operands exp)))))))])]) (make-Const (length (App-operands exp)))))])])
(let* ([extended-cenv (let* ([extended-cenv
(extend-compile-time-environment/scratch-space (extend-compile-time-environment/scratch-space
cenv cenv
@ -1690,6 +1691,9 @@
[(Constant? exp) [(Constant? exp)
(make-Const (Constant-v exp))] (make-Const (Constant-v exp))]
[(PrimitiveKernelValue? exp)
exp]
[else [else
'?])) '?]))

12
compiler/il-structs.rkt
View File

@ -383,7 +383,8 @@
;; Raises an exception that says that we're doing a ;; Raises an exception that says that we're doing a
;; procedure application, but got sent an incorrect number. ;; procedure application, but got sent an incorrect number.
(define-struct: RaiseArityMismatchError! ([expected : Arity] (define-struct: RaiseArityMismatchError! ([proc : OpArg]
[expected : Arity]
[received : OpArg]) [received : OpArg])
#:transparent) #:transparent)
@ -424,10 +425,9 @@
#:transparent) #:transparent)
;; Give an alternative locator to the module. Assumes the module has ;; Give an alternative locator to the module as a main module.
;; already been installed. ;; Assumes the module has already been installed.
(define-struct: AliasModuleName! ([from : ModuleLocator] (define-struct: AliasModuleAsMain! ([from : ModuleLocator])
[to : ModuleLocator])
#:transparent) #:transparent)
;; Given the module locator, do any finalizing operations, like ;; Given the module locator, do any finalizing operations, like
@ -462,7 +462,7 @@
InstallModuleEntry! InstallModuleEntry!
MarkModuleInvoked! MarkModuleInvoked!
AliasModuleName! AliasModuleAsMain!
FinalizeModuleInvokation! FinalizeModuleInvokation!
)) ))

4
compiler/optimize-il.rkt
View File

@ -14,10 +14,10 @@
(: optimize-il ((Listof Statement) -> (Listof Statement))) (: optimize-il ((Listof Statement) -> (Listof Statement)))
(define (optimize-il statements) (define (optimize-il statements)
statements #;statements
;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...) ;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
;; We should do some more optimizations here, like peephole... ;; We should do some more optimizations here, like peephole...
#;(let loop ([statements (filter not-no-op? statements)]) (let loop ([statements (filter not-no-op? statements)])
(cond (cond
[(empty? statements) [(empty? statements)
empty] empty]

3
get-dependencies.rkt
View File

@ -1,8 +1,7 @@
#lang typed/racket/base #lang typed/racket/base
(require "compiler/expression-structs.rkt" (require "compiler/expression-structs.rkt"
"compiler/lexical-structs.rkt" "compiler/lexical-structs.rkt"
"sets.rkt" "sets.rkt")
racket/match)
;; Collect the complete list of dependencies for a module. ;; Collect the complete list of dependencies for a module.

2
js-assembler/assemble-helpers.rkt
View File

@ -80,7 +80,7 @@
[(EnvPrefixReference? target) [(EnvPrefixReference? target)
(assemble-prefix-reference target)] (assemble-prefix-reference target)]
[(PrimitivesReference? target) [(PrimitivesReference? target)
(format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))] (format "RUNTIME.Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]
[(ControlFrameTemporary? target) [(ControlFrameTemporary? target)
(assemble-control-frame-temporary target)] (assemble-control-frame-temporary target)]
[(ModulePrefixTarget? target) [(ModulePrefixTarget? target)

6
js-assembler/assemble-open-coded.rkt
View File

@ -137,12 +137,12 @@
[(box) [(box)
(format "(typeof(~a) === 'object' && (~a).length === 1)" (format "(typeof(~a) === 'object' && (~a).length === 1)"
operand-string operand-string)])]) operand-string operand-string)])])
(format "((~a) ? (~a) : RUNTIME.raise(MACHINE, new Error('~a: expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))" (format "((~a) ? (~a) : RUNTIME.raiseArgumentTypeError(MACHINE, ~s, ~s, ~s, ~a))"
test-string test-string
operand-string operand-string
caller (symbol->string caller)
(symbol->string domain) (symbol->string domain)
(add1 pos) pos
operand-string))])) operand-string))]))

38
js-assembler/assemble-perform-statement.rkt
View File

@ -14,18 +14,40 @@
(cond (cond
[(CheckToplevelBound!? op) [(CheckToplevelBound!? op)
(format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }" (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { RUNTIME.raiseUnboundToplevelError(MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }"
(CheckToplevelBound!-depth op) (CheckToplevelBound!-depth op)
(CheckToplevelBound!-pos op) (CheckToplevelBound!-pos op)
(CheckToplevelBound!-depth op) (CheckToplevelBound!-depth op)
(CheckToplevelBound!-pos op))] (CheckToplevelBound!-pos op))]
[(CheckClosureArity!? op) [(CheckClosureArity!? op)
(format "if (! (MACHINE.proc instanceof RUNTIME.Closure && RUNTIME.isArityMatching(MACHINE.proc.arity, ~a))) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure:\" + MACHINE.proc.displayName); } }" (format #<<EOF
if (! (MACHINE.proc instanceof RUNTIME.Closure)) {
RUNTIME.raiseOperatorIsNotClosure(MACHINE, MACHINE.proc);
}
if (! RUNTIME.isArityMatching(MACHINE.proc.arity, ~a)) {
RUNTIME.raiseArityMismatchError(MACHINE.proc,
MACHINE.proc.arity,
~a);
}
EOF
(assemble-oparg (CheckClosureArity!-arity op))
(assemble-oparg (CheckClosureArity!-arity op)))] (assemble-oparg (CheckClosureArity!-arity op)))]
[(CheckPrimitiveArity!? op) [(CheckPrimitiveArity!? op)
(format "if (! (typeof(MACHINE.proc) === 'function' && RUNTIME.isArityMatching(MACHINE.proc.arity, ~a))) { if (! (typeof(MACHINE.proc) === 'function')) { throw new Error(\"not a primitive procedure\"); } else { throw new Error(\"arity failure:\" + MACHINE.proc.displayName); } }" (format #<<EOF
if (! (typeof(MACHINE.proc) === 'function')) {
RUNTIME.raiseOperatorIsNotPrimitiveProcedure(MACHINE, MACHINE.proc);
}
if (! RUNTIME.isArityMatching(MACHINE.proc.arity, ~a)) {
RUNTIME.raiseArityMismatchError(MACHINE.proc,
MACHINE.proc.arity,
~a);
}
EOF
(assemble-oparg (CheckPrimitiveArity!-arity op))
(assemble-oparg (CheckPrimitiveArity!-arity op)))] (assemble-oparg (CheckPrimitiveArity!-arity op)))]
@ -126,7 +148,8 @@
[(RaiseArityMismatchError!? op) [(RaiseArityMismatchError!? op)
(format "RUNTIME.raiseArityMismatchError(MACHINE, ~a, ~a);" (format "RUNTIME.raiseArityMismatchError(MACHINE, ~a, ~a, ~a);"
(assemble-oparg (RaiseArityMismatchError!-proc op))
(assemble-arity (RaiseArityMismatchError!-expected op)) (assemble-arity (RaiseArityMismatchError!-expected op))
(assemble-oparg (RaiseArityMismatchError!-received op)))] (assemble-oparg (RaiseArityMismatchError!-received op)))]
@ -152,10 +175,9 @@
(symbol->string (ModuleLocator-name (MarkModuleInvoked!-path op))))] (symbol->string (ModuleLocator-name (MarkModuleInvoked!-path op))))]
[(AliasModuleName!? op) [(AliasModuleAsMain!? op)
(format "MACHINE.modules[~s] = MACHINE.modules[~s];" (format "MACHINE.mainModules.push(MACHINE.modules[~s]);"
(symbol->string (ModuleLocator-name (AliasModuleName!-to op))) (symbol->string (ModuleLocator-name (AliasModuleAsMain!-from op))))]
(symbol->string (ModuleLocator-name (AliasModuleName!-from op))))]
[(FinalizeModuleInvokation!? op) [(FinalizeModuleInvokation!? op)
(format "MACHINE.modules[~s].finalizeModuleInvokation();" (format "MACHINE.modules[~s].finalizeModuleInvokation();"

10
js-assembler/assemble.rkt
View File

@ -12,8 +12,7 @@
racket/string racket/string
racket/list) racket/list)
(provide assemble/write-invoke-module-as-main (provide assemble/write-invoke
assemble/write-invoke
fracture fracture
assemble-basic-block assemble-basic-block
assemble-statement) assemble-statement)
@ -25,13 +24,6 @@
(: assemble/write-invoke-module-as-main (Symbol Output-Port -> Void))
(define (assemble/write-invoke-module-as-main module-name op)
;; FIXME
(void))
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void)) (: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
;; Writes out the JavaScript code that represents the anonymous invocation expression. ;; Writes out the JavaScript code that represents the anonymous invocation expression.
;; What's emitted is a function expression that, when invoked, runs the ;; What's emitted is a function expression that, when invoked, runs the

125
js-assembler/mini-runtime.js
View File

@ -65,6 +65,7 @@
this.control = []; // Arrayof (U Frame CallFrame PromptFrame) this.control = []; // Arrayof (U Frame CallFrame PromptFrame)
this.running = false; this.running = false;
this.modules = {}; // String -> ModuleRecord this.modules = {}; // String -> ModuleRecord
this.mainModules = []; // Arrayof String
this.params = { this.params = {
// currentDisplayer: DomNode -> Void // currentDisplayer: DomNode -> Void
@ -139,6 +140,10 @@
// External invokation of a module. // External invokation of a module.
ModuleRecord.prototype.invoke = function(MACHINE, succ, fail) { ModuleRecord.prototype.invoke = function(MACHINE, succ, fail) {
MACHINE = MACHINE || plt.runtime.currentMachine;
succ = succ || function(){};
fail = fail || function(){};
var oldErrorHandler = MACHINE.params['currentErrorHandler']; var oldErrorHandler = MACHINE.params['currentErrorHandler'];
var afterGoodInvoke = function(MACHINE) { var afterGoodInvoke = function(MACHINE) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
@ -331,11 +336,12 @@
callerName) { callerName) {
if (predicate(val)) { if (predicate(val)) {
return true; return true;
} } else {
else { raiseArgumentTypeError(MACHINE,
raise(MACHINE, new Error(callerName + ": expected " + expectedTypeName callerName,
+ " as argument " + (index + 1) expectedTypeName,
+ " but received " + val)); index,
val);
} }
}; };
@ -348,6 +354,22 @@
} }
}; };
var raiseUnboundToplevelError = function(MACHINE, name) {
raise(MACHINE, new Error("Not bound: " + name));
};
var raiseArgumentTypeError = function(MACHINE,
callerName,
expectedTypeName,
argumentOffset,
actualValue) {
raise(MACHINE,
new Error(callerName + ": expected " + expectedTypeName
+ " as argument " + (argumentOffset + 1)
+ " but received " + actualValue));
};
var raiseContextExpectedValuesError = function(MACHINE, expected) { var raiseContextExpectedValuesError = function(MACHINE, expected) {
raise(MACHINE, raise(MACHINE,
new Error("expected " + expected + new Error("expected " + expected +
@ -355,11 +377,9 @@
MACHINE.argcount + " values")); MACHINE.argcount + " values"));
}; };
var raiseArityMismatchError = function(MACHINE, expected, received) { var raiseArityMismatchError = function(MACHINE, proc, expected, received) {
raise(MACHINE, raise(MACHINE,
new Error("expected " + expected + new Error("expected " + expected + " values, received " + received + " values"));
" values, received " +
received + " values"));
}; };
var raiseOperatorApplicationError = function(MACHINE, operator) { var raiseOperatorApplicationError = function(MACHINE, operator) {
@ -368,6 +388,17 @@
operator)); operator));
}; };
var raiseOperatorIsNotClosure = function(MACHINE, operator) {
raise(MACHINE,
new Error("not a closure: " + operator));
};
var raiseOperatorIsNotPrimitiveProcedure = function(MACHINE, operator) {
raise(MACHINE,
new Error("not a primitive procedure: " + operator));
};
var raiseUnimplementedPrimitiveError = function(MACHINE, name) { var raiseUnimplementedPrimitiveError = function(MACHINE, name) {
raise(MACHINE, raise(MACHINE,
new Error("unimplemented kernel procedure: " + name)) new Error("unimplemented kernel procedure: " + name))
@ -1278,7 +1309,77 @@
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
(function(scope) {
scope.ready = function(f) {
if (runtimeIsReady) {
notifyWaiter(f);
} else {
readyWaiters.push(f);
}
};
scope.setReadyTrue = function() {
var i;
runtimeIsReady = true;
for (i = 0; i < readyWaiters.length; i++) {
notifyWaiter(readyWaiters[i]);
}
readyWaiters = [];
};
var runtimeIsReady = false;
var readyWaiters = [];
var notifyWaiter = function(w) {
setTimeout(w, 0);
};
})(this);
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
// Executes all programs that have been labeled as a main module
var invokeMains = function(machine, succ, fail) {
plt.runtime.ready(function() {
machine = machine || plt.runtime.currentMachine;
succ = succ || function() {};
fail = fail || function() {};
var mainModules = machine.mainModules.slice();
var loop = function() {
if (mainModules.length > 0) {
var nextModule = mainModules.shift();
nextModule.invoke(machine, loop, fail);
} else {
succ();
}
};
setTimeout(loop, 0);
});
};
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
// Exports // Exports
exports['currentMachine'] = new Machine();
exports['invokeMains'] = invokeMains;
exports['Primitives'] = Primitives;
exports['ready'] = ready;
// Private: the runtime library will set this flag to true when
// the library has finished loading.
exports['setReadyTrue'] = setReadyTrue;
exports['Machine'] = Machine; exports['Machine'] = Machine;
exports['Frame'] = Frame; exports['Frame'] = Frame;
exports['CallFrame'] = CallFrame; exports['CallFrame'] = CallFrame;
@ -1294,10 +1395,16 @@
exports['testArgument'] = testArgument; exports['testArgument'] = testArgument;
exports['testArity'] = testArity; exports['testArity'] = testArity;
exports['raise'] = raise; exports['raise'] = raise;
exports['raiseUnboundToplevelError'] = raiseUnboundToplevelError;
exports['raiseArgumentTypeError'] = raiseArgumentTypeError;
exports['raiseContextExpectedValuesError'] = raiseContextExpectedValuesError; exports['raiseContextExpectedValuesError'] = raiseContextExpectedValuesError;
exports['raiseArityMismatchError'] = raiseArityMismatchError; exports['raiseArityMismatchError'] = raiseArityMismatchError;
exports['raiseOperatorApplicationError'] = raiseOperatorApplicationError; exports['raiseOperatorApplicationError'] = raiseOperatorApplicationError;
exports['raiseOperatorIsNotPrimitiveProcedure'] = raiseOperatorIsNotPrimitiveProcedure;
exports['raiseOperatorIsNotClosure'] = raiseOperatorIsNotClosure;
exports['raiseUnimplementedPrimitiveError'] = raiseUnimplementedPrimitiveError; exports['raiseUnimplementedPrimitiveError'] = raiseUnimplementedPrimitiveError;

78
js-assembler/package.rkt
View File

@ -4,17 +4,22 @@
"quote-cdata.rkt" "quote-cdata.rkt"
"../make.rkt" "../make.rkt"
"../make-structs.rkt" "../make-structs.rkt"
"get-runtime.rkt" (prefix-in runtime: "get-runtime.rkt")
(prefix-in racket: racket/base)) (prefix-in racket: racket/base))
(provide package (provide package
package-anonymous package-anonymous
package-standalone-xhtml) package-standalone-xhtml
get-standalone-code
write-standalone-code
get-runtime
write-runtime)
;; Packager: produce single .js files to be included to execute a ;; Packager: produce single .js files to be included to execute a
;; program. Follows module dependencies. ;; program.
@ -36,7 +41,7 @@
;; indicates whether we should continue following module paths. ;; indicates whether we should continue following module paths.
;; ;;
;; The generated output defines a function called 'invoke' with ;; The generated output defines a function called 'invoke' with
;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS). When called, it'll ;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS). When called, it will
;; execute the code to either run standalone expressions or ;; execute the code to either run standalone expressions or
;; load in modules. ;; load in modules.
(define (package source-code (define (package source-code
@ -62,13 +67,15 @@
(fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {") (fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {")
(make (cons only-bootstrapped-code (fprintf op " plt.runtime.ready(function() {")
(list (make-MainModuleSource source-code))) (make (list (make-MainModuleSource source-code))
packaging-configuration) packaging-configuration)
(fprintf op " });");
(fprintf op "});\n")) (fprintf op "});\n"))
;; package-standalone-xhtml: X output-port -> void ;; package-standalone-xhtml: X output-port -> void
(define (package-standalone-xhtml source-code op) (define (package-standalone-xhtml source-code op)
(display *header* op) (display *header* op)
@ -78,7 +85,43 @@
;; get-runtime: -> string
(define (get-runtime)
(let ([buffer (open-output-string)])
(write-runtime buffer)
(get-output-string buffer)))
;; write-runtime: output-port -> void
(define (write-runtime op)
(let ([packaging-configuration
(make-Configuration
;; should-follow?
(lambda (p) #t)
;; on
(lambda (ast stmts)
(assemble/write-invoke stmts op)
(fprintf op "(MACHINE, function() { "))
;; after
(lambda (ast stmts)
(fprintf op " }, FAIL, PARAMS);"))
;; last
(lambda ()
(fprintf op "SUCCESS();")))])
(display (runtime:get-runtime) op)
(newline op)
(fprintf op "(function(MACHINE, SUCCESS, FAIL, PARAMS) {")
(make (list only-bootstrapped-code) packaging-configuration)
(fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
;; *header* : string
(define *header* (define *header*
#<<EOF #<<EOF
<!DOCTYPE html> <!DOCTYPE html>
@ -93,6 +136,7 @@ EOF
) )
;; get-code: source -> string
(define (get-code source-code) (define (get-code source-code)
(let ([buffer (open-output-string)]) (let ([buffer (open-output-string)])
(package source-code (package source-code
@ -101,15 +145,33 @@ EOF
(get-output-string buffer))) (get-output-string buffer)))
;; get-standalone-code: source -> string
(define (get-standalone-code source-code)
(let ([buffer (open-output-string)])
(write-standalone-code source-code buffer)
(get-output-string buffer)))
;; write-standalone-code: source output-port -> void
(define (write-standalone-code source-code op)
(package-anonymous source-code
#:should-follow? (lambda (p) #t)
#:output-port op)
(fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n"))
(define *footer* (define *footer*
#<<EOF #<<EOF
<![CDATA[ <![CDATA[
var invokeMainModule = function() { var invokeMainModule = function() {
var MACHINE = new plt.runtime.Machine(); var MACHINE = plt.runtime.currentMachine;
invoke(MACHINE, invoke(MACHINE,
function() { function() {
MACHINE.modules['*main*'].invoke( plt.runtime.invokeMains(
MACHINE, MACHINE,
function() { function() {
// On main module invokation success // On main module invokation success

28
lang/kernel.rkt
View File

@ -235,7 +235,7 @@
;; number->string ;; number->string
;; string->number ;; string->number
;; procedure? ;; procedure?
;; pair? pair?
;; (undefined? -undefined?) ;; (undefined? -undefined?)
;; immutable? ;; immutable?
;; void? ;; void?
@ -263,7 +263,7 @@
;; box? ;; box?
;; hash? ;; hash?
;; eqv? ;; eqv?
;; equal? equal?
;; caar ;; caar
;; cadr ;; cadr
;; cdar ;; cdar
@ -277,20 +277,20 @@
;; caddr ;; caddr
;; cdddr ;; cdddr
;; cadddr ;; cadddr
;; length length
;; list? ;; list?
;; list* ;; list*
;; list-ref ;; list-ref
;; list-tail ;; list-tail
;; append append
;; reverse reverse
;; for-each ;; for-each
;; map map
;; andmap ;; andmap
;; ormap ;; ormap
;; memq ;; memq
;; memv ;; memv
;; member member
;; memf ;; memf
;; assq ;; assq
;; assv ;; assv
@ -354,13 +354,13 @@
;; bytes=? ;; bytes=?
;; bytes<? ;; bytes<?
;; bytes>? ;; bytes>?
;; make-vector make-vector
;; vector vector
;; vector-length vector-length
;; vector-ref vector-ref
;; vector-set! vector-set!
;; vector->list vector->list
;; list->vector list->vector
;; build-vector ;; build-vector
;; char=? ;; char=?
;; char<? ;; char<?

12
make-structs.rkt
View File

@ -1,17 +1,9 @@
#lang typed/racket/base #lang typed/racket/base
(require "compiler/compiler.rkt" (require "compiler/il-structs.rkt"
"compiler/il-structs.rkt"
"compiler/lexical-structs.rkt"
"compiler/bootstrapped-primitives.rkt" "compiler/bootstrapped-primitives.rkt"
"compiler/compiler-structs.rkt"
"compiler/expression-structs.rkt" "compiler/expression-structs.rkt"
"get-dependencies.rkt")
"get-dependencies.rkt"
"parameters.rkt"
"sets.rkt"
racket/list
racket/match)

6
make.rkt
View File

@ -3,7 +3,6 @@
(require "compiler/compiler.rkt" (require "compiler/compiler.rkt"
"compiler/il-structs.rkt" "compiler/il-structs.rkt"
"compiler/lexical-structs.rkt" "compiler/lexical-structs.rkt"
"compiler/bootstrapped-primitives.rkt"
"compiler/compiler-structs.rkt" "compiler/compiler-structs.rkt"
"compiler/expression-structs.rkt" "compiler/expression-structs.rkt"
"get-dependencies.rkt" "get-dependencies.rkt"
@ -51,9 +50,8 @@
(values ast (append stmts (values ast (append stmts
;; Set the main module name ;; Set the main module name
(list (make-PerformStatement (list (make-PerformStatement
(make-AliasModuleName! (make-AliasModuleAsMain!
maybe-module-locator maybe-module-locator)))))]
(make-ModuleLocator '*main* '*main*))))))]
[else [else
(values ast stmts)])))] (values ast stmts)])))]

6
simulator/simulator.rkt
View File

@ -476,12 +476,12 @@
(ModuleLocator-name (MarkModuleInvoked!-path op)))]) (ModuleLocator-name (MarkModuleInvoked!-path op)))])
(set-module-record-invoked?! module-record #t) (set-module-record-invoked?! module-record #t)
'ok)] 'ok)]
[(AliasModuleName!? op) [(AliasModuleAsMain!? op)
(let ([module-record (let ([module-record
(hash-ref (machine-modules m) (hash-ref (machine-modules m)
(ModuleLocator-name (AliasModuleName!-from op)))]) (ModuleLocator-name (AliasModuleAsMain!-from op)))])
(hash-set! (machine-modules m) (hash-set! (machine-modules m)
(ModuleLocator-name (AliasModuleName!-to op)) '*main*
module-record) module-record)
'ok)] 'ok)]
[(FinalizeModuleInvokation!? op) [(FinalizeModuleInvokation!? op)

2
tests/test-assemble.rkt
View File

@ -2,7 +2,7 @@
(require "browser-evaluate.rkt" (require "browser-evaluate.rkt"
"../js-assembler/assemble.rkt" "../js-assembler/assemble.rkt"
"../js-assembler/get-runtime.rkt" "../js-assembler/package.rkt"
"../compiler/lexical-structs.rkt" "../compiler/lexical-structs.rkt"
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
racket/port racket/port

1
tests/test-browser-evaluate.rkt
View File

@ -1,6 +1,5 @@
#lang racket #lang racket
(require "browser-evaluate.rkt" (require "browser-evaluate.rkt"
"../js-assembler/get-runtime.rkt"
"../js-assembler/package.rkt" "../js-assembler/package.rkt"
"../make-structs.rkt") "../make-structs.rkt")

1
tests/test-conform-browser.rkt
View File

@ -1,7 +1,6 @@
#lang racket #lang racket
(require "browser-evaluate.rkt" (require "browser-evaluate.rkt"
"../js-assembler/package.rkt" "../js-assembler/package.rkt"
"../js-assembler/get-runtime.rkt"
"../make-structs.rkt" "../make-structs.rkt"
racket/port racket/port
racket/runtime-path) racket/runtime-path)

1
tests/test-earley-browser.rkt
View File

@ -1,7 +1,6 @@
#lang racket #lang racket
(require "browser-evaluate.rkt" (require "browser-evaluate.rkt"
"../js-assembler/package.rkt" "../js-assembler/package.rkt"
"../js-assembler/get-runtime.rkt"
"../make-structs.rkt" "../make-structs.rkt"
racket/port racket/port
racket/runtime-path racket/runtime-path

36
whalesong.rkt
View File

@ -2,9 +2,7 @@
#lang racket/base #lang racket/base
(require racket/list (require racket/list
racket/match
racket/string racket/string
racket/path
"make-structs.rkt" "make-structs.rkt"
"js-assembler/package.rkt") "js-assembler/package.rkt")
@ -14,11 +12,30 @@
;; * Build standalone .xhtml application. ;; * Build standalone .xhtml application.
;; ;;
;; $ whalesong build main-module-name.rkt ;; $ whalesong build main-module-name.rkt
;;
;;
;; * Print out the runtime library to standard output.
;;
;; $ whalesong get-runtime
;;
;;
;; * Print out the JavaScript for the program.
;;
;; $ whalesong get-javascript main-module-name.rkt
;; TODO: error trapping
(define commands `((build (define commands `((build
,(lambda (args) ,(lambda (args)
(do-the-build args))))) (do-the-build args)))
(get-runtime
,(lambda (args)
(print-the-runtime)))
(get-javascript
,(lambda (args)
(get-javascript-code (first args))))))
;; listof string ;; listof string
(define command-names (map (lambda (x) (symbol->string (car x))) (define command-names (map (lambda (x) (symbol->string (car x)))
@ -64,4 +81,17 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (print-the-runtime)
(write-runtime (current-output-port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (get-javascript-code filename)
(write-standalone-code (make-ModuleSource (build-path filename)) (current-output-port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(at-toplevel) (at-toplevel)