yiyunliu/core-in-racket
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Yiyun Liu 2025-06-06 15:59:11 -04:00
parent ad1ca1d796
commit d6236dc442
1 changed files with 32 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

51
semantics.rkt
View file

@ -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))]