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

implementing list splicing

Browse Source
This commit is contained in:
Danny Yoo 2011-04-10 18:49:18 -04:00
parent 286e68920b
commit 9831504245
7 changed files with 175 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
assemble.rkt
View File

@ -171,6 +171,8 @@ EOF
empty]
[(SetFrameCallee!? op)
empty]
[(SpliceListIntoStack!? op)
empty]
[(FixClosureShellMap!? op)
empty]))
@ -485,7 +487,10 @@ EOF
", "))]
[(SetFrameCallee!? op)
(format "MACHINE.control[MACHINE.control.length-1].proc = ~a;"
(assemble-oparg (SetFrameCallee!-proc op)))]))
(assemble-oparg (SetFrameCallee!-proc op)))]
[(SpliceListIntoStack!? op)
(format "RUNTIME.spliceListIntoStack(MACHINE, ~a);"
(assemble-oparg (SpliceListIntoStack!-depth op)))]))

13
bootstrapped-primitives.rkt
View File

@ -166,14 +166,13 @@
;; Push the procedure into proc.
(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
(make-PopEnvironment (make-Const 1)
(make-Const 0))
(make-PopEnvironment (make-Const 1) (make-Const 0))
;; Correct the number of arguments to be passed.
(make-AssignPrimOpStatement 'val
(make-CallKernelPrimitiveProcedure 'sub1
(list (make-Reg 'val))
(list 'number)
(list #f)))
(make-AssignImmediateStatement 'argcount (make-SubtractArg (make-Reg 'argcount)
(make-Const 1)))
;; Splice in the list argument.
(make-PerformStatement (make-SpliceListIntoStack! (make-SubtractArg (make-Reg 'argcount)
(make-Const 1))))
after-apply-code
(make-AssignPrimOpStatement (make-PrimitivesReference 'apply)

7
il-structs.rkt
View File

@ -260,6 +260,12 @@
#:transparent)
;; Splices the list structure that lives in env[depth] into position.
;; Depth must evaluate to a natural.
(define-struct: SpliceListIntoStack! ([depth : OpArg])
#:transparent)
(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
[depth : Natural]
@ -283,6 +289,7 @@
FixClosureShellMap!
SetFrameCallee!
SpliceListIntoStack!
RestoreEnvironment!
RestoreControl!))

25
runtime.js
View File

@ -233,7 +233,24 @@
}
raise(new Error("restoreControl: unable to find tag " + tag));
}
};
// Splices the list argument in the environment. Adjusts MACHINE.argcount
// appropriately.
var spliceListIntoStack = function(MACHINE, depth) {
var lst = MACHINE.env[MACHINE.env.length - 1 - depth];
var vals = [];
while(lst !== NULL) {
vals.push(lst[0]);
lst = lst[1];
}
vals.reverse();
MACHINE.env.splice.apply(MACHINE.env,
[MACHINE.env.length - 1 - depth, 1].concat(vals));
MACHINE.argcount = MACHINE.argcount + vals.length - 1;
};
// An arity is either a primitive number, an ArityAtLeast instance,
@ -848,6 +865,10 @@
exports['captureControl'] = captureControl;
exports['restoreControl'] = restoreControl;
exports['trampoline'] = trampoline;
exports['spliceListIntoStack'] = spliceListIntoStack;
exports['isNumber'] = isNumber;
exports['isPair'] = isPair;
exports['isVector'] = isVector;
@ -860,6 +881,6 @@
exports['heir'] = heir;
exports['makeClassPredicate'] = makeClassPredicate;
exports['trampoline'] = trampoline;
}).call(this);

38
simulator.rkt
View File

@ -21,7 +21,7 @@
(require/typed "simulator-helpers.rkt"
[ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
[ensure-primitive-value (SlotValue -> PrimitiveValue)]
[ensure-list (Any -> PrimitiveValue)]
[ensure-list (Any -> (U Null MutablePair))]
[racket->PrimitiveValue (Any -> PrimitiveValue)])
@ -290,6 +290,24 @@
[frame (ensure-CallFrame (control-top m))])
(set-CallFrame-proc! frame proc-value)
'ok)]
[(SpliceListIntoStack!? op)
(let*: ([stack-index : Natural (ensure-natural (evaluate-oparg m (SpliceListIntoStack!-depth op)))]
[arg-list : (Listof PrimitiveValue)
(mutable-pair-list->list
(ensure-list (env-ref m stack-index)))])
(set-machine-env! m (append (take (machine-env m) stack-index)
arg-list
(drop (machine-env m) (add1 stack-index))))
(set-machine-stack-size! m (ensure-natural (+ (machine-stack-size m)
(length arg-list)
-1)))
(set-machine-argcount! m
(ensure-natural
(+ (ensure-natural (machine-argcount m))
(length arg-list)
-1)))
'ok)]
[(RestoreControl!? op)
@ -312,6 +330,24 @@
'ok])))
(: mutable-pair-list->list ((U Null MutablePair) -> (Listof PrimitiveValue)))
(define (mutable-pair-list->list mlst)
(cond
[(null? mlst)
'()]
[else
(cons (MutablePair-h mlst)
(mutable-pair-list->list (let ([t (MutablePair-t mlst)])
(cond
[(null? t)
t]
[(MutablePair? t)
t]
[else
(error 'mutable-pair-list->list "Not a list: ~s" t)]))))]))
(: arity-match? (Arity Natural -> Boolean))
(define (arity-match? an-arity n)
(cond

23
test-assemble.rkt
View File

@ -368,3 +368,26 @@
,(make-PerformStatement (make-CheckToplevelBound! 0 0)))
"MACHINE.env[0][0]")
"Shriram")
(test (E-many `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))))
"MACHINE.argcount + ',' + MACHINE.env[0] + ',' + MACHINE.env[1] + ',' + MACHINE.env[2]")
"3,3,2,1")
(test (E-many `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const "hello"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
(make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 3))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2))))
"MACHINE.argcount + ',' + MACHINE.env[0] + ',' + MACHINE.env[1] + ',' + MACHINE.env[2] + ',' + MACHINE.env[3] + ',' + MACHINE.env[4]")
"5,3,2,1,world,hello")

116
test-simulator.rkt
View File

@ -33,11 +33,11 @@
;; run: machine -> machine
;; Run the machine to completion.
(define (run m)
(define (run! m)
(cond
[(can-step? m)
(step! m)
(run m)]
(run! m)]
[else
m]))
@ -72,13 +72,13 @@
(let* ([m (new-machine `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42)))
#f)]
[m (run m)])
[m (run! m)])
(test (machine-env m) '(42)))
;; Assigning to a boxed environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))))]
[m (run m)])
[m (run! m)])
(test (machine-env m) (list (box 42))))
@ -89,13 +89,13 @@
,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #t))))]
[m (run m)])
[m (run! m)])
(test (machine-env m) (list 42 (box 42))))
(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))
,(make-PushEnvironment 1 #f)))]
[m (run m)])
[m (run! m)])
(test (machine-env m) (list (make-undefined)
(box 42))))
(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
@ -103,7 +103,7 @@
,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))))]
[m (run m)])
[m (run! m)])
(test (machine-env m) (list (box 42)
(box 42))))
@ -113,54 +113,54 @@
;; Assigning to another environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 2 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))))]
[m (run m)])
[m (run! m)])
(test (machine-env m) `(,(make-undefined) 42)))
;; Assigning to another environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 2 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42))))]
[m (run m)])
[m (run! m)])
(test (machine-env m) `(42 ,(make-undefined))))
;; PushEnv
(let ([m (new-machine `(,(make-PushEnvironment 20 #f)))])
(test (machine-env (run m)) (build-list 20 (lambda (i) (make-undefined)))))
(test (machine-env (run! m)) (build-list 20 (lambda (i) (make-undefined)))))
;; PopEnv
(let ([m (new-machine `(,(make-PushEnvironment 20 #f)
,(make-PopEnvironment (make-Const 20) (make-Const 0))))])
(test (machine-env (run m)) '()))
(test (machine-env (run! m)) '()))
(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
,(make-PopEnvironment (make-Const 1) (make-Const 0))))])
(test (machine-env (run m)) '("dewey" "louie")))
(test (machine-env (run! m)) '("dewey" "louie")))
(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
,(make-PopEnvironment (make-Const 1) (make-Const 1))))])
(test (machine-env (run m)) '("hewie" "louie")))
(test (machine-env (run! m)) '("hewie" "louie")))
(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
,(make-PopEnvironment (make-Const 1) (make-Const 2))))])
(test (machine-env (run m)) '("hewie" "dewey")))
(test (machine-env (run! m)) '("hewie" "dewey")))
(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
,(make-PopEnvironment (make-Const 2) (make-Const 1))))])
(test (machine-env (run m)) '("hewie")))
(test (machine-env (run! m)) '("hewie")))
@ -172,7 +172,7 @@
,(make-PushControlFrame 'bar)
baz
))])
(test (machine-control (run m))
(test (machine-control (run! m))
(list (make-CallFrame 'bar #f)
(make-CallFrame 'foo #f))))
@ -187,7 +187,7 @@
baz
,(make-PopControlFrame)
))])
(test (machine-control (run m))
(test (machine-control (run! m))
(list (make-CallFrame 'foo #f))))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
@ -198,7 +198,7 @@
baz
,(make-PopControlFrame)
,(make-PopControlFrame)))])
(test (machine-control (run m))
(test (machine-control (run! m))
(list)))
@ -213,7 +213,7 @@
on-false
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
end))])
(test (machine-val (run m))
(test (machine-val (run! m))
'ok))
;; TestAndBranch: try the false branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const #f))
@ -223,7 +223,7 @@
on-false
,(make-AssignImmediateStatement 'val (make-Const 'ok))
end))])
(test (machine-val (run m))
(test (machine-val (run! m))
'ok))
;; Test for primitive procedure
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const '+))
@ -233,7 +233,7 @@
on-true
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
end))])
(test (machine-val (run m))
(test (machine-val (run! m))
'ok))
;; Give a primitive procedure in val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
@ -243,7 +243,7 @@
on-true
,(make-AssignImmediateStatement 'val (make-Const 'ok))
end))])
(test (machine-val (run m))
(test (machine-val (run! m))
'ok))
;; Give a primitive procedure in proc, but test val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
@ -253,7 +253,7 @@
on-true
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end))])
(test (machine-val (run m))
(test (machine-val (run! m))
'not-a-procedure))
;; Give a primitive procedure in proc and test proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
@ -263,7 +263,7 @@
on-true
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end))])
(test (machine-val (run m))
(test (machine-val (run! m))
'a-procedure))
@ -272,7 +272,7 @@
;; AssignPrimOpStatement
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
(test (first (machine-env (run m)))
(test (first (machine-env (run! m)))
(make-toplevel '(+ - * =)
(list (lookup-primitive '+)
(lookup-primitive '-)
@ -282,20 +282,20 @@
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))))])
(test (machine-env (run m))
(test (machine-env (run! m))
(list (make-toplevel '(some-variable) (list "Danny")))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))))])
(test (machine-env (run m))
(test (machine-env (run! m))
(list (make-toplevel '(some-variable another) (list (make-undefined) "Danny")))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PushEnvironment 5 #f)
,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0) (make-Reg 'val))))])
(test (machine-env (run m))
(test (machine-env (run! m))
(list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined)
(make-toplevel '(some-variable) (list "Danny")))))
@ -309,7 +309,7 @@
(with-handlers ((exn:fail? (lambda (exn)
(void))))
(run m)
(run! m)
(raise "I expected an error")))
;; check-toplevel-bound shouldn't fail here.
@ -317,7 +317,7 @@
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0))))])
(void (run m)))
(void (run! m)))
@ -336,7 +336,7 @@
procedure-entry))
0
(make-hash))])
(test (machine-env (run m))
(test (machine-env (run! m))
;; Check that the environment has installed the expected closure values.
(list 1 2 3 true false)))
@ -352,7 +352,7 @@
(list->vector `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))))
0
(make-hash))])
(test (machine-val (run m))
(test (machine-val (run! m))
'procedure-entry))
@ -364,7 +364,7 @@
procedure-entry
end
))])
(test (machine-val (run m))
(test (machine-val (run! m))
(make-closure 'procedure-entry 0 (list) 'procedure-entry)))
;; make-compiled-procedure: Capturing a few variables.
@ -382,7 +382,7 @@
procedure-entry
end
))])
(test (machine-val (run m))
(test (machine-val (run! m))
(make-closure 'procedure-entry 0 (list 'larry 'moe)
'procedure-entry)))
@ -404,7 +404,7 @@
procedure-entry
end
))])
(test (machine-val (run m))
(test (machine-val (run! m))
(make-closure 'procedure-entry 0 (list (make-toplevel '(x y z) (list "x" "y" "z")))
'procedure-entry)))
@ -432,7 +432,7 @@
procedure-entry
end
))])
(test (machine-val (run m))
(test (machine-val (run! m))
(make-closure 'procedure-entry
0
(list (make-toplevel '(x y z) (list "x" "y" "z"))
@ -444,7 +444,7 @@
;; Test toplevel lookup
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))))])
(test (machine-val (run m))
(test (machine-val (run! m))
(lookup-primitive '+)))
;; Test lexical lookup
@ -455,7 +455,7 @@
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))))])
(test (machine-val (run m))
(test (machine-val (run! m))
'larry))
;; Another lexical lookup test
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
@ -465,7 +465,7 @@
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 1 #f))))])
(test (machine-val (run m))
(test (machine-val (run! m))
'curly))
;; ApplyPrimitiveProcedure
@ -478,10 +478,10 @@
,(make-AssignImmediateStatement 'argcount (make-Const 2))
,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
after))])
(test (machine-val (run m))
(test (machine-val (run! m))
(+ 126389 42))
(test (machine-env (run m))
(test (machine-env (run! m))
(list 126389 42 (make-toplevel '(+) (list (lookup-primitive '+))))))
@ -490,5 +490,35 @@
foo
,(make-PushControlFrame 'foo)
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))])
(test (machine-proc (run m))
'foo))
(test (machine-proc (run! m))
'foo))
;; Splicing
(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0)))))])
(run! m)
(test (machine-argcount m)
3)
(test (machine-env m)
'(1 2 3)))
(let ([m (new-machine `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const "hello"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
(make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 3))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2)))))])
(run! m)
(test (machine-argcount m)
5)
(test (machine-env m)
'("hello" "world" 1 2 3)))