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