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

changing test and branch's test structure from symbols. Some test will need to take more that one operand, eventually.

Browse Source
This commit is contained in:
Danny Yoo 2011-04-29 14:08:11 -04:00
parent e5509eecd3
commit 5d674b18d5
10 changed files with 214 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
assemble.rkt
View File

@ -193,21 +193,21 @@ EOF
[(TestAndBranchStatement? stmt)
(let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
(cond
[(eq? test 'false?)
[(TestFalse? test)
(format "if (~a === false) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-oparg (TestFalse-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'one?)
[(TestOne? test)
(format "if (~a === 1) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-oparg (TestOne-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'zero?)
[(TestZero? test)
(format "if (~a === 0) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-oparg (TestZero-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'primitive-procedure?)
[(TestPrimitiveProcedure? test)
(format "if (typeof(~a) === 'function') { ~a };"
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-oparg (TestPrimitiveProcedure-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))]
[(GotoStatement? stmt)

4
bootstrapped-primitives.rkt
View File

@ -174,8 +174,8 @@
[on-single-value (make-label 'onSingleValue)])
`(,(make-GotoStatement (make-Label after-values-body-defn))
,values-entry
,(make-TestAndBranchStatement 'one? (make-Reg 'argcount) on-single-value)
,(make-TestAndBranchStatement 'zero? (make-Reg 'argcount) on-zero-values)
,(make-TestAndBranchStatement (make-TestOne (make-Reg 'argcount)) on-single-value)
,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) on-zero-values)
;; Common case: we're running multiple values. Put the first in the val register
;; and go to the multiple value return.

3
collect-jump-targets.rkt
View File

@ -118,8 +118,7 @@
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
(define (collect-primitive-command op)
empty
#;(cond
(cond
[(CheckToplevelBound!? op)
empty]
[(CheckClosureArity!? op)

160
compiler.rkt
View File

@ -49,10 +49,11 @@
(make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Reg 'val))))))))))
(define-struct: lam+cenv ([lam : Lam]
(define-struct: lam+cenv ([lam : (U Lam CaseLam)]
[cenv : CompileTimeEnvironment]))
(: collect-all-lams (Expression -> (Listof lam+cenv)))
;; Finds all the lambdas in the expression.
(define (collect-all-lams exp)
@ -79,6 +80,12 @@
(cons (make-lam+cenv exp cenv)
(loop (Lam-body exp)
(extract-lambda-cenv exp cenv)))]
[(CaseLam? exp)
(cons (make-lam+cenv exp cenv)
(apply append (map (lambda: ([lam : Lam])
(loop lam cenv))
(CaseLam-clauses exp))))]
[(Seq? exp)
(apply append (map (lambda: ([e : Expression]) (loop e cenv))
(Seq-actions exp)))]
@ -163,6 +170,8 @@
(compile-branch exp cenv target linkage)]
[(Lam? exp)
(compile-lambda exp cenv target linkage)]
[(CaseLam? exp)
(compile-case-lambda exp cenv target linkage)]
[(Seq? exp)
(compile-sequence (Seq-actions exp)
cenv
@ -380,8 +389,7 @@
p-code
(append-instruction-sequences
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'false?
(make-Reg 'val)
`(,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val))
f-branch)))
t-branch
c-code
@ -456,13 +464,90 @@
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (Lam-entry-label exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp))
(Lam-arity exp)
(Lam-closure-map exp)
(Lam-name exp)))))
singular-context-check))))
(: compile-case-lambda (CaseLam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Similar to compile-lambda.
(define (compile-case-lambda exp cenv target linkage)
(let ([singular-context-check (emit-singular-context linkage)]
[n (length (CaseLam-clauses exp))])
;; We have to build all the lambda values, and then create a single CaseLam that holds onto
;; all of them.
(end-with-linkage
linkage
cenv
(append-instruction-sequences
;; Make some temporary space for the lambdas
(make-instruction-sequence
`(,(make-PushEnvironment n #f)))
;; Compile each of the lambdas
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[target : Target])
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (Lam-entry-label lam)
(Lam-arity lam)
(shift-closure-map (Lam-closure-map lam) n)
(Lam-name lam))))))
(CaseLam-clauses exp)
(build-list (length (CaseLam-clauses exp))
(lambda: ([i : Natural])
(make-EnvLexicalReference i #f)))))
;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas.
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (CaseLam-entry-label exp)
(merge-arities (map Lam-arity (CaseLam-clauses exp)))
(build-list n (lambda: ([i : Natural]) i))
(CaseLam-name exp)))
;; Finally, pop off the scratch space.
,(make-PopEnvironment (make-Const n) (make-Const 0))))
singular-context-check))))
(: Lam-arity (Lam -> Arity))
(define (Lam-arity lam)
(if (Lam-rest? lam)
(make-ArityAtLeast (Lam-num-parameters lam))
(Lam-num-parameters lam)))
(: shift-closure-map ((Listof Natural) Natural -> (Listof Natural)))
(define (shift-closure-map closure-map n)
(map (lambda: ([i : Natural]) (+ i n))
closure-map))
(: merge-arities ((Listof Arity) -> Arity))
(define (merge-arities arities)
(cond [(empty? (rest arities))
(first arities)]
[else
(let ([first-arity (first arities)]
[merged-rest (merge-arities (rest arities))])
(cond
[(AtomicArity? first-arity)
(cond [(AtomicArity? merged-rest)
(list first-arity merged-rest)]
[(listof-atomic-arity? merged-rest)
(cons first-arity merged-rest)])]
[(listof-atomic-arity? first-arity)
(cond [(AtomicArity? merged-rest)
(append first-arity (list merged-rest))]
[(listof-atomic-arity? merged-rest)
(append first-arity merged-rest)])]))]))
(: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Write out code for lambda expressions, minus the closure map.
@ -517,7 +602,34 @@
lam-body-code)))
(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence))
(define (compile-case-lambda-body exp cenv)
empty-instruction-sequence
#;(append-instruction-sequences
(make-instruction-sequence
`(,(CaseLam-entry-label exp)))
(apply append-instruction-sequences
;; todo: Add the case-dispatch based on arity matching.
(map (lambda: ([lam : Lam]
[i : Natural])
(let ([not-match (make-label)])
(make-instruction-sequence
`(,(make-TestAndBranchStatement arity-mismatch?
(make-Const (Lam-arity lam))
(make-Reg 'argcount))
;; Set the procedure register to the lam
,(make-AssignImmediateStatement
'proc
(make-CaseLamRef (make-Reg 'proc) (make-Const i)))
,(make-GotoStatement (make-Label (Lam-entry-point lam)))
,not-match))))
(CaseLam-clauses exp)
(build-list (length (CaseLam-clauses)) (lambda: ([i : Natural]) i))))))
(: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence))
;; Compile several lambda bodies, back to back.
(define (compile-lambda-bodies exps)
@ -525,9 +637,19 @@
[(empty? exps)
(make-instruction-sequence '())]
[else
(append-instruction-sequences (compile-lambda-body (lam+cenv-lam (first exps))
(lam+cenv-cenv (first exps)))
(compile-lambda-bodies (rest exps)))]))
(let: ([lam : (U Lam CaseLam) (lam+cenv-lam (first exps))]
[cenv : CompileTimeEnvironment (lam+cenv-cenv (first exps))])
(cond
[(Lam? lam)
(append-instruction-sequences (compile-lambda-body lam
cenv)
(compile-lambda-bodies (rest exps)))]
[(CaseLam? lam)
(append-instruction-sequences
(compile-case-lambda-body lam cenv)
(compile-lambda-bodies (rest exps)))]))]))
(: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment))
@ -995,8 +1117,8 @@
(make-NextLinkage (linkage-context linkage))])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure?
(make-Reg 'proc)
`(,(make-TestAndBranchStatement (make-TestPrimitiveProcedure
(make-Reg 'proc))
primitive-branch)))
@ -1217,9 +1339,8 @@
`(
;; if the wrong number of arguments come in, die
,(make-TestAndBranchStatement
'zero?
(make-SubtractArg (make-Reg 'argcount)
(make-Const context))
(make-TestZero (make-SubtractArg (make-Reg 'argcount)
(make-Const context)))
after-value-check)))
on-return
(make-instruction-sequence
@ -1539,7 +1660,7 @@
next-linkage/keep-multiple-on-stack)
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'zero? (make-Reg 'argcount) after-args-evaluated)
`(,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) after-args-evaluated)
;; In the common case where we do get values back, we push val onto the stack too,
;; so that we have n values on the stack before we jump to the procedure call.
,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f)))
@ -1726,6 +1847,13 @@
(Lam-closure-map exp))
(Lam-entry-label exp))]
[(CaseLam? exp)
(make-CaseLam (CaseLam-name exp)
(map (lambda: ([lam : Lam])
(ensure-lam (adjust-expression-depth lam n skip)))
(CaseLam-clauses exp))
(CaseLam-entry-label exp))]
[(Seq? exp)
(make-Seq (map (lambda: ([action : Expression])
(adjust-expression-depth action n skip))

37
expression-structs.rkt
View File

@ -8,7 +8,7 @@
(define-type Expression (U Top Constant
ToplevelRef LocalRef
ToplevelSet
Branch Lam Seq Splice App
Branch CaseLam Lam Seq Splice App
Let1
LetVoid
LetRec
@ -24,12 +24,10 @@
(define-struct: Constant ([v : Any]) #:transparent)
(define-struct: ToplevelRef ([depth : Natural]
[pos : Natural])
#:transparent)
[pos : Natural]) #:transparent)
(define-struct: LocalRef ([depth : Natural]
[unbox? : Boolean])
#:transparent)
[unbox? : Boolean]) #:transparent)
(define-struct: ToplevelSet ([depth : Natural]
[pos : Natural]
@ -40,6 +38,10 @@
[consequent : Expression]
[alternative : Expression]) #:transparent)
(define-struct: CaseLam ([name : (U Symbol False)]
[clauses : (Listof Lam)]
[entry-label : Symbol]) #:transparent)
(define-struct: Lam ([name : (U Symbol False)]
[num-parameters : Natural]
[rest? : Boolean]
@ -53,45 +55,38 @@
[operands : (Listof Expression)]) #:transparent)
(define-struct: Let1 ([rhs : Expression]
[body : Expression])
#:transparent)
[body : Expression]) #:transparent)
(define-struct: LetVoid ([count : Natural]
[body : Expression]
[boxes? : Boolean])
#:transparent)
[boxes? : Boolean]) #:transparent)
(define-struct: LetRec ([procs : (Listof Lam)]
[body : Expression])
#:transparent)
[body : Expression]) #:transparent)
(define-struct: InstallValue ([count : Natural] ;; how many values to install
[depth : Natural] ;; how many slots to skip
[body : Expression]
[box? : Boolean])
#:transparent)
[box? : Boolean]) #:transparent)
(define-struct: BoxEnv ([depth : Natural]
[body : Expression])
#:transparent)
[body : Expression]) #:transparent)
(define-struct: WithContMark ([key : Expression]
[value : Expression]
[body : Expression])
#:transparent)
[body : Expression]) #:transparent)
(define-struct: ApplyValues ([proc : Expression]
[args-expr : Expression])
#:transparent)
[args-expr : Expression]) #:transparent)
;; Multiple value definition
(define-struct: DefValues ([ids : (Listof ToplevelRef)]
[rhs : Expression])
#:transparent)
[rhs : Expression]) #:transparent)

35
il-structs.rkt
View File

@ -178,8 +178,9 @@
(define-struct: PerformStatement ([op : PrimitiveCommand])
#:transparent)
(define-struct: TestAndBranchStatement ([op : PrimitiveTest]
[operand : OpArg]
[label : Symbol])
#:transparent)
@ -194,6 +195,7 @@
MakeCompiledProcedure
MakeCompiledProcedureShell
ApplyPrimitiveProcedure
MakeBoxedEnvironmentValue
@ -215,6 +217,7 @@
[display-name : (U Symbol False)])
#:transparent)
;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't
;; bother with trying to capture the free variables.
(define-struct: MakeCompiledProcedureShell ([label : Symbol]
@ -261,21 +264,19 @@
;; The following is used with TestStatement: each is passed the register-rand and
;; is expected to
;; Primitive tests (used with TestAndBranch)
(define-type PrimitiveTest (U
;; register -> boolean
;; Meant to branch when the register value is false.
'false?
'one?
'zero?
;; register -> boolean
;; Meant to branch when the register value is a primitive
;; procedure
'primitive-procedure?
TestFalse
TestOne
TestZero
TestPrimitiveProcedure
))
(define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)
@ -473,11 +474,13 @@
(define-type Arity (U Natural ArityAtLeast (Listof (U Natural ArityAtLeast))))
;; Arity
(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
(define-type AtomicArity (U Natural ArityAtLeast))
(define-struct: ArityAtLeast ([value : Natural])
#:transparent)
(define-predicate listof-atomic-arity? (Listof (U Natural ArityAtLeast)))
(define-predicate AtomicArity? AtomicArity)
(define-predicate listof-atomic-arity? (Listof AtomicArity))

1
simulator-structs.rkt
View File

@ -163,7 +163,6 @@
;; undefined value
(define-struct: undefined ()
#:transparent)

23
simulator.rkt
View File

@ -199,17 +199,18 @@
(: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
(define (step-test-and-branch! m stmt)
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
[argval : SlotValue (evaluate-oparg m (TestAndBranchStatement-operand stmt))])
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
(if (let: ([v : Boolean (cond
[(eq? test 'false?)
(not argval)]
[(eq? test 'one?)
(= (ensure-natural argval) 1)]
[(eq? test 'zero?)
(= (ensure-natural argval) 0)]
[(eq? test 'primitive-procedure?)
(primitive-proc? argval)])])
[(TestFalse? test)
(not (evaluate-oparg m (TestFalse-operand test)))]
[(TestOne? test)
(= (ensure-natural (evaluate-oparg m (TestOne-operand test)))
1)]
[(TestZero? test)
(= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
0)]
[(TestPrimitiveProcedure? test)
(primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))])])
v)
(jump! m (TestAndBranchStatement-label stmt))
'ok)))
@ -500,7 +501,7 @@
(MakeCompiledProcedureShell-arity op)
'()
(MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)]
[args : (Listof PrimitiveValue)

12
test-assemble.rkt
View File

@ -282,7 +282,7 @@
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42))
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'onFalse)
,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val)) 'onFalse)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
onFalse
@ -292,7 +292,7 @@
;; TestAndBranch: try the false branch
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f))
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'onFalse)
,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val)) 'onFalse)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
onFalse
@ -302,7 +302,7 @@
;; Test for primitive procedure
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'onTrue)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
onTrue
@ -313,7 +313,7 @@
;; Give a primitive procedure in val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'onTrue)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
onTrue
@ -324,7 +324,7 @@
;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'onTrue)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
onTrue
@ -335,7 +335,7 @@
;; Give a primitive procedure in proc and test proc
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'proc) 'onTrue)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
onTrue

12
test-simulator.rkt
View File

@ -207,7 +207,7 @@
;; TestAndBranch: try the true branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'on-false)
,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val)) 'on-false)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
on-false
@ -217,7 +217,7 @@
'ok))
;; TestAndBranch: try the false branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const #f))
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'on-false)
,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val)) 'on-false)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
on-false
@ -227,7 +227,7 @@
'ok))
;; Test for primitive procedure
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const '+))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'on-true)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
on-true
@ -237,7 +237,7 @@
'ok))
;; Give a primitive procedure in val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'on-true)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
on-true
@ -247,7 +247,7 @@
'ok))
;; Give a primitive procedure in proc, but test val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'on-true)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
on-true
@ -257,7 +257,7 @@
'not-a-procedure))
;; Give a primitive procedure in proc and test proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'proc) 'on-true)
,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
on-true