Return Addr when allocated and Node (or continuation) when unallocated

semantics.rkt

@@ -10,7 +10,7 @@
 (define-type Stack (Listof Addr))
 (define-type Dump Null)
 (define-type Heap (TreeListof Node))
-(define-type Node (∪ (List Addr Addr) CoreScDefn Integer))
+(define-type Node (∪ (List Addr Addr) CoreScDefn Integer 'Undef))
 (define-type Globals (Immutable-HashTable Name Addr))
 (define-type Stats Nonnegative-Integer)
 
@@ -52,6 +52,16 @@
         [heap (treelist-add heap node)])
     (values heap addr)))
 
+(: update-heap-undef (-> Heap Addr Node Heap))
+(define (update-heap-undef heap addr node)
+  (if (eq? (treelist-ref heap addr) 'Undef)
+      (update-heap heap addr node)
+      (error "Address in heap is not undefined")))
+
+(: update-heap (-> Heap Addr Node Heap))
+(define (update-heap heap addr node)
+  (treelist-set heap addr node))
+
 (: lookup-node (-> Heap Addr Node))
 (define lookup-node treelist-ref)
 
@@ -113,27 +123,30 @@
 
 (: step-sc (-> Stack State (Listof Name) CoreExpr State))
 (define (step-sc rstack state arg-names body)
-  (let ([heap (State-heap state)])
-    (let*-values ([(new-env new-stack)
-                  (for/fold ([globals : Globals (State-globals state)]
-                             [stack : Stack rstack])
-                            ([arg-name : Name arg-names])
-                    (if (null? stack)
-                        (error "Not enough arguments to apply the supercombinator")
-                        (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))]
-                  [(new-heap addr) (instantiate-body body new-env heap)])
-      (let ([new-stack (cons addr new-stack)])
-        (struct-copy State state [stack new-stack] [heap new-heap])))))
+  (let*-values ([(heap addr) (allocate-node (State-heap state) 'Undef)]
+                [(new-env new-stack)
+                 (for/fold ([globals : Globals (State-globals state)]
+                            [stack : Stack rstack])
+                           ([arg-name : Name arg-names])
+                   (if (null? stack)
+                       (error "Not enough arguments to apply the supercombinator")
+                       (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))]
+                )
+    (let ([new-heap (instantiate-body body new-env heap addr)]
+          [new-stack (cons addr new-stack)])
+      (struct-copy State state [stack new-stack] [heap new-heap]))))
 
-(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr)))
-(define (instantiate-body e env heap)
+(: instantiate-body (-> CoreExpr Globals Heap Addr Heap))
+(define (instantiate-body e env heap addr)
   (match e
-    [(? integer?) (allocate-node heap e)]
+    [(? integer?) (update-heap-undef heap addr e)]
     [(list f a)
-     (let*-values ([(heap0 addr-f) (instantiate-body f env heap)]
-                   [(heap1 addr-a) (instantiate-body a env heap0)])
-       (allocate-node heap1 (list addr-f addr-a)))]
-    [(? symbol?) (values heap (lookup-globals env e))]
+     (let*-values ([(heap0 addr0) (allocate-node heap 'Undef)]
+                   [(heap1 addr1) (allocate-node heap0 'Undef)])
+       (let* ([heap2 (instantiate-body f env heap1 addr0)]
+              [heap3 (instantiate-body a env heap2 addr1)])
+         (update-heap-undef heap3 addr (list addr0 addr1))))]
+    [(? symbol?) (update-heap-undef heap addr (lookup-globals env e))]
     [(list 'let binds e)
      (let-values ([(env heap) (instantiate-binds binds env heap)])
        (instantiate-body e env heap))]