trying to do paired labels

assemble.rkt

@@ -29,6 +29,10 @@
                        (displayln (assemble-basic-block basic-block) op)
                        (newline op))
               basic-blocks)
+    (for-each (lambda: ([a-paired-label : PairedLabel])
+                       (assemble-paired-label a-paired-label op)
+                       (newline op))
+              (collect-paired-labels stmts))
     (fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
     (fprintf op "MACHINE.params.currentSuccessHandler = success;\n")
     (fprintf op #<<EOF
@@ -124,7 +128,18 @@ EOF
 
 
 
-
+(: 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)
@@ -493,3 +508,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

@@ -821,20 +821,22 @@
 (: 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))]
-          [compiled-linkage : Linkage (if (ReturnLinkage? linkage)
-                                          linkage
-                                          after-call)])
-         (append-instruction-sequences
-          (compile-proc-appl extended-cenv 
-                             (make-Label (StaticallyKnownLam-entry-point static-knowledge))
-                             n 
-                             target
-                             compiled-linkage)
-          (end-with-linkage
-           linkage
-           cenv
-           (LabelLinkage-label after-call)))))
+  (let-values ([(after-call-multiple
+                 after-call-single)
+                (make-paired-labels 'afterCallMultiple 'afterCallSingle)])
+    (let*: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
+                                            linkage
+                                            (make-Label after-call-single))])
+           (append-instruction-sequences
+            (compile-proc-appl extended-cenv 
+                               (make-Label (StaticallyKnownLam-entry-point static-knowledge))
+                               n 
+                               target
+                               compiled-linkage)
+            (end-with-linkage
+             linkage
+             cenv
+             after-call-single)))))
 
 
 

il-structs.rkt

@@ -304,10 +304,10 @@
 
 
 
-(: make-paired-labels (Symbol -> (values Symbol PairedLabel)))
-(define (make-paired-labels name)
-  (let* ([first-label (make-label name)]
-         [second-label (make-label name)])
+(: 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))))