Refactor instantiate to allow pre-allocation of nodes

semantics.rkt

@@ -132,25 +132,31 @@
                     (if (null? stack)
                         (error "Not enough arguments to apply the supercombinator")
                         (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))]
-                  [(heap node) (instantiate-body body new-env heap)]
-                  [(heap addr) (allocate-node heap node)])
+                  [(heap addr) (instantiate-and-allocate body new-env heap)])
       (let ([new-stack (cons addr new-stack)])
         (struct-copy State state [stack new-stack] [heap heap])))))
 
-(: instantiate-body (-> CoreExpr Globals Heap (∪ Addr (-> Addr Heap))))
-(define (instantiate-body e env heap)
+(: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr)))
+(define (instantiate-and-allocate e env heap)
+  (let ([res (instantiate e env heap)])
+    (cond
+      [(number? res)
+       (values heap res)]
+      [else
+       (allocate-node (car res) (cdr res))])))
+
+(: instantiate (-> CoreExpr Globals Heap (∪ Addr (Pair Heap Node))))
+(define (instantiate e env heap)
   (match e
-    [(? integer?) (λ (x : Addr) (update-heap-undef heap x e))]
+    [(? integer?) (cons heap e)]
     [(list f a)
-     (let*-values ([(heap node0) (instantiate-body f env heap)]
-                   [(heap node1) (instantiate-body a env heap)]
-                   [(heap addr-f) (allocate-node heap node0)]
-                   [(heap addr-a) (allocate-node heap node1)])
-       (allocate-node heap (list addr-f addr-a)))]
-    [(? symbol?) (values heap (lookup-globals env e))]
+     (let*-values ([(heap addr-f) (instantiate-and-allocate f env heap)]
+                   [(heap addr-a) (instantiate-and-allocate a env heap)])
+       (cons heap (list addr-f addr-a)))]
+    [(? symbol?) (lookup-globals env e)]
     [(list 'let binds e)
      (let-values ([(env heap) (instantiate-binds binds env heap)])
-       (instantiate-body e env heap))]
+       (instantiate e env heap))]
     [_ (error "unimplemented")]))
 
 (: instantiate-binds (-> CoreBinds Globals Heap (Values Globals Heap)))
@@ -165,8 +171,7 @@
 (define (instantiate-bind bind old-env new-env heap)
   (let ([x (first bind)]
         [e (second bind)])
-    (let*-values ([(heap node) (instantiate-body e old-env heap)]
-                  [(heap addr) (allocate-node heap node)])
+    (let*-values ([(heap addr) (instantiate-and-allocate e old-env heap)])
       (values (update-globals new-env x addr) heap))))