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

Add in-place update

Browse source
This commit is contained in:
Yiyun Liu 2025-06-07 19:05:26 -04:00
parent 815fb10e89
commit d827f9f683
1 changed files with 12 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

23
semantics.rkt
View file

@ -150,18 +150,18 @@
(let ([stack (State-stack state)]) (let ([stack (State-stack state)])
(match stack (match stack
[(cons addr rstack) [(cons addr rstack)
(step-node rstack state (lookup-node (State-heap state) addr))] (step-node addr rstack state (lookup-node (State-heap state) addr))]
['() (error "Invalid state")]))) ['() (error "Invalid state")])))
(: step-node (-> Stack State Node State)) (: step-node (-> Addr Stack State Node State))
(define (step-node rstack st n) (define (step-node addr rstack st n)
(cond (cond
[(integer-node? n) (error "A number cannot be stepped any further!")] [(integer-node? n) (error "A number cannot be stepped any further!")]
[(ap-node? n) (update-stack (λ (stack) (push-addr stack (ap-fun n))) st)] [(ap-node? n) (update-stack (λ (stack) (push-addr stack (ap-fun n))) st)]
[(undef-node? n) (error "An undefined node is being stepped!")] [(undef-node? n) (error "An undefined node is being stepped!")]
[(sc-node? n) [(sc-node? n)
(let-values ([(args body) (match-sc n)]) (let-values ([(args body) (match-sc n)])
(step-sc rstack st args body))] (step-sc addr rstack st args body))]
[(indirect-node? n) [(indirect-node? n)
(update-stack (λ (_) (push-addr rstack (indirect-addr n))) st)])) (update-stack (λ (_) (push-addr rstack (indirect-addr n))) st)]))
@ -171,18 +171,19 @@
[(list _ a) a] [(list _ a) a]
[_ (error "Not an application node")])) [_ (error "Not an application node")]))
(: step-sc (-> Stack State (Listof Name) CoreExpr State)) (: step-sc (-> Addr Stack State (Listof Name) CoreExpr State))
(define (step-sc rstack state arg-names body) (define (step-sc root rstack state arg-names body)
(let ([heap (State-heap state)]) (let ([heap (State-heap state)])
(let*-values ([(new-env new-stack) (let*-values ([(new-env new-stack root)
(for/fold ([globals : Globals (State-globals state)] (for/fold ([globals : Globals (State-globals state)]
[stack : Stack rstack]) [stack : Stack rstack]
[root : Addr root])
([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) (car stack))))])
[(heap addr) (instantiate-and-allocate body new-env heap)]) (let* ([heap (instantiate-and-assign body new-env heap root)]
(let ([new-stack (cons addr new-stack)]) [new-stack (cons root new-stack)])
(struct-copy State state [stack new-stack] [heap heap]))))) (struct-copy State state [stack new-stack] [heap heap])))))
(: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr))) (: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr)))