implementing list splicing

assemble.rkt

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

bootstrapped-primitives.rkt

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

il-structs.rkt

@@ -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!))

runtime.js

@@ -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);

simulator.rkt

@@ -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)])
              
 
@@ -291,6 +291,24 @@
              (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)
            (let: ([tag-value : ContinuationPromptTagValue
@@ -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

test-assemble.rkt

@@ -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")

test-simulator.rkt

@@ -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))
+  (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)))