still debugging, but something broke

assemble.rkt

@@ -14,14 +14,15 @@
 
 
 ;; Parameter that controls the generation of a trace.
-(define current-emit-debug-trace? (make-parameter #f))
+(define current-emit-debug-trace? (make-parameter #t))
 
 
 
 (: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
 ;; Writes out the JavaScript code that represents the anonymous invocation expression.
 (define (assemble/write-invoke stmts op)
-  (let ([basic-blocks (fracture stmts)])
+  (let* ([basic-blocks (fracture stmts)]
+         [basic-block-labels (map BasicBlock-name basic-blocks)])
     (fprintf op "(function(MACHINE, success, fail, params) {\n")
     (fprintf op "var param;\n")
     (fprintf op "var RUNTIME = plt.runtime;\n")
@@ -29,6 +30,15 @@
                        (displayln (assemble-basic-block basic-block) op)
                        (newline op))
               basic-blocks)
+    (for-each (lambda: ([a-paired-label : PairedLabel])
+                       (cond [(member (PairedLabel-label a-paired-label)
+                                      basic-block-labels)
+                              
+                              (assemble-paired-label a-paired-label op)
+                              (newline op)]
+                             [else
+                              (void)]))
+              (collect-paired-labels stmts))
     (fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
     (fprintf op "MACHINE.params.currentSuccessHandler = success;\n")
     (fprintf op #<<EOF
@@ -68,35 +78,74 @@ EOF
             [(null? stmts)
              (reverse (cons (make-BasicBlock name (reverse acc))
                             basic-blocks))]
-            [(symbol? (car stmts))
-             (cond
-               [(member (car stmts) jump-targets)
-                (loop (car stmts)
-                      '()
-                      (cons (make-BasicBlock name  
-                                             (if last-stmt-goto? 
-                                                 (reverse acc)
-                                                 (reverse (append `(,(make-GotoStatement (make-Label (car stmts))))
-                                                                  acc))))
-                            basic-blocks)
-                      (cdr stmts)
-                      last-stmt-goto?)]
-               [else
-                (loop name
-                      acc
-                      basic-blocks
-                      (cdr stmts)
-                      last-stmt-goto?)])]
             [else
-             (loop name
+             (let ([first-stmt (car stmts)])
-                   (cons (car stmts) acc)
+               (cond
-                   basic-blocks
+                 
-                   (cdr stmts)
+                 [(symbol? first-stmt)
-                   (GotoStatement? (car stmts)))]))))
+                  (cond
-
+                    [(member first-stmt jump-targets)
+                     (loop first-stmt
+                           '()
+                           (cons (make-BasicBlock 
+                                  name  
+                                  (if last-stmt-goto? 
+                                      (reverse acc)
+                                      (reverse (append `(,(make-GotoStatement (make-Label first-stmt)))
+                                                       acc))))
+                                 basic-blocks)
+                           (cdr stmts)
+                           last-stmt-goto?)]
+                    [else
+                     (loop name
+                           acc
+                           basic-blocks
+                           (cdr stmts)
+                           last-stmt-goto?)])]
+                 
+                 [(PairedLabel? first-stmt)
+                  (cond
+                    [(member (PairedLabel-label first-stmt) jump-targets)
+                     (loop (PairedLabel-label first-stmt)
+                           '()
+                           (cons (make-BasicBlock 
+                                  name  
+                                  (if last-stmt-goto? 
+                                      (reverse acc)
+                                      (reverse (append `(,(make-GotoStatement 
+                                                           (make-Label (PairedLabel-label first-stmt))))
+                                                       acc))))
+                                 basic-blocks)
+                           (cdr stmts)
+                           last-stmt-goto?)]
+                    [else
+                     (loop name
+                           acc
+                           basic-blocks
+                           (cdr stmts)
+                           last-stmt-goto?)])]
+                 
+                 [else
+                  (loop name
+                        (cons first-stmt acc)
+                        basic-blocks
+                        (cdr stmts)
+                        (GotoStatement? first-stmt))]))]))))
 
 
 
+(: collect-paired-labels ((Listof Statement) -> (Listof PairedLabel)))
+(define (collect-paired-labels stmts)
+  (cond
+    [(empty? stmts)
+     empty]
+    [else
+     (let ([first-stmt (first stmts)])
+       (cond
+         [(PairedLabel? first-stmt)
+          (cons first-stmt (collect-paired-labels (rest stmts)))]
+         [else
+          (collect-paired-labels (rest stmts))]))]))
 
 
 ;; collect-general-jump-targets: (listof stmt) -> (listof label)
@@ -176,6 +225,8 @@ EOF
                   (append (cond
                             [(symbol? stmt)
                              empty]
+                            [(PairedLabel? stmt)
+                             (list (PairedLabel-previous stmt))]
                             [(AssignImmediateStatement? stmt)
                              (let: ([v : OpArg (AssignImmediateStatement-value stmt)])
                                    (cond 
@@ -463,3 +514,10 @@ EOF
      (assemble-label a-location)]))
 
 
+(: assemble-paired-label (PairedLabel Output-Port -> 'ok))
+;; Write out the code to make it easy to jump to the previous label.
+(define (assemble-paired-label a-paired-label op)
+  (fprintf op "~a.predecessor = ~a;"
+           (PairedLabel-label a-paired-label)
+           (PairedLabel-previous a-paired-label))
+  'ok)

compile.rkt

@@ -778,63 +778,78 @@
 ;; cenv is the compile-time enviroment before arguments have been shifted in.
 ;; extended-cenv is the compile-time environment after arguments have been shifted in.
 (define (compile-general-procedure-call cenv extended-cenv n target linkage)
-  (let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
+  (let-values ([(after-call-multiple after-call-single)
-         [compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
+                (make-paired-labels 'afterCallMultiple 'afterCallSingle)])
-         [after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
+    (let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
-        (let: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
+           [compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))])
-                                               linkage
+          (let: ([compiled-linkage : Linkage 
-                                               after-call)])
+                                   (if (ReturnLinkage? linkage)
-              (append-instruction-sequences
+                                       linkage
-               (make-instruction-sequence 
+                                       (make-LabelLinkage (PairedLabel-label after-call-single)))])
-                `(,(make-TestAndBranchStatement 'primitive-procedure?
-                                                'proc
-                                                (LabelLinkage-label primitive-branch))))
-               
-               
-               ;; Compiled branch
-               (LabelLinkage-label compiled-branch)
-               (make-instruction-sequence
-                `(,(make-PerformStatement (make-CheckClosureArity! n))))
-               (compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage)
-               
-               
-               
-               (LabelLinkage-label primitive-branch)
-               (end-with-linkage
-                linkage
-                cenv
                 (append-instruction-sequences
                  (make-instruction-sequence 
-                  `(,(make-AssignPrimOpStatement 
+                  `(,(make-TestAndBranchStatement 'primitive-procedure?
-                      ;; Optimization: we put the result directly in the registers, or in
+                                                  'proc
-                      ;; the appropriate spot on the stack.  This takes into account the popenviroment
+                                                  (LabelLinkage-label primitive-branch))))
-                      ;; that happens right afterwards.
+                 
-                      (adjust-target-depth target n)                     
+                 
-                      (make-ApplyPrimitiveProcedure n))))
+                 ;; Compiled branch
-                 (if (not (= n 0))
+                 (LabelLinkage-label compiled-branch)
-                     (make-instruction-sequence
+                 (make-instruction-sequence
-                      `(,(make-PopEnvironment n 0)))
+                  `(,(make-PerformStatement (make-CheckClosureArity! n))))
-                     empty-instruction-sequence)
+                 (compile-proc-appl extended-cenv
-                 (LabelLinkage-label after-call)))))))
+                                    (make-Reg 'val)
+                                    n 
+                                    target
+                                    compiled-linkage)
+                                  
+                 
+                 (LabelLinkage-label primitive-branch)
+                 (end-with-linkage
+                  linkage
+                  cenv
+                  (append-instruction-sequences
+                   (make-instruction-sequence 
+                    `(,(make-AssignPrimOpStatement 
+                        ;; Optimization: we put the result directly in the registers, or in
+                        ;; the appropriate spot on the stack.  This takes into account the popenviroment
+                        ;; that happens right afterwards.
+                        (adjust-target-depth target n)                     
+                        (make-ApplyPrimitiveProcedure n))))
+                   (if (not (= n 0))
+                       (make-instruction-sequence
+                        `(,(make-PopEnvironment n 0)))
+                       empty-instruction-sequence)
+                   (make-instruction-sequence
+                    `(,(make-GotoStatement (make-Label (PairedLabel-label after-call-single)))))
+                   
+                   (make-instruction-sequence 
+                    `(,after-call-multiple
+                      ,after-call-single)))))))))
 
 
 (: compile-procedure-call/statically-known-lam 
    (StaticallyKnownLam CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
 (define (compile-procedure-call/statically-known-lam static-knowledge cenv extended-cenv n target linkage)
-  (let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]
+  (let-values ([(after-call-multiple
-          [compiled-linkage : Linkage (if (ReturnLinkage? linkage)
+                 after-call-single)
-                                          linkage
+                (make-paired-labels 'afterCallMultiple 'afterCallSingle)])
-                                          after-call)])
+    (let*: ([compiled-linkage : Linkage 
-         (append-instruction-sequences
+                              (if (ReturnLinkage? linkage)
-          (compile-proc-appl extended-cenv 
+                                  linkage
-                             (make-Label (StaticallyKnownLam-entry-point static-knowledge))
+                                  (make-LabelLinkage (PairedLabel-label after-call-single)))])
-                             n 
+           (append-instruction-sequences
-                             target
+            (compile-proc-appl extended-cenv 
-                             compiled-linkage)
+                               (make-Label (StaticallyKnownLam-entry-point static-knowledge))
-          (end-with-linkage
+                               n 
-           linkage
+                               target
-           cenv
+                               compiled-linkage)
-           (LabelLinkage-label after-call)))))
+            (end-with-linkage
+             linkage
+             cenv
+             (make-instruction-sequence
+              `(,after-call-multiple
+                ,after-call-single)))))))
 
 
 

il-structs.rkt

@@ -52,6 +52,9 @@
 
 
 
+  
+
+
 ;; instruction sequences
 (define-type UnlabeledStatement (U 
                                  
@@ -73,6 +76,7 @@
 
 (define-type Statement (U UnlabeledStatement
                           Symbol  ;; label
+                          PairedLabel
                           ))
 
 (define-struct: AssignImmediateStatement ([target : Target]
@@ -292,6 +296,24 @@
 
 
 
+;; A PairedLabel is like a regular label, but it knows about
+;; a previous label as well.  Used for efficient implementation 
+;; of multiple return values.
+(define-struct: PairedLabel ([label : Symbol]
+                             [previous : Symbol]))
+
+
+
+(: make-paired-labels (Symbol Symbol -> (values Symbol PairedLabel)))
+(define (make-paired-labels first-name second-name)
+  (let* ([first-label (make-label first-name)]
+         [second-label (make-label second-name)])
+  (values first-label (make-PairedLabel second-label first-label))))
+
+
+
+
+
 
 ;; Linkage
 (define-struct: NextLinkage ())

simulator.rkt

@@ -61,6 +61,8 @@
                           (let: ([stmt : Statement (vector-ref (machine-text m) i)])
                                 (when (symbol? stmt)
                                   (hash-set! (machine-jump-table m) stmt i))
+                                (when (PairedLabel? stmt)
+                                  (hash-set! (machine-jump-table m) (PairedLabel-label stmt) i))
                                 (loop (add1 i)))))
                   m))]))
 
@@ -88,6 +90,8 @@
                   (cond
                     [(symbol? i)
                      'ok]
+                    [(PairedLabel? i)
+                     'ok]
                     [(AssignImmediateStatement? i)
                      (step-assign-immediate! m i)]
                     [(AssignPrimOpStatement? i)