diff --git a/semantics.rkt b/semantics.rkt index 8e65454..aa3e773 100644 --- a/semantics.rkt +++ b/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))]