From ba13ba5dbd6a1a6de581e5365877536a74a9663a Mon Sep 17 00:00:00 2001 From: Yiyun Liu Date: Sat, 7 Jun 2025 16:34:28 -0400 Subject: [PATCH] Add unallocated node type --- printer.rkt | 12 +++-- semantics.rkt | 121 +++++++++++++++++++++++++++++++++++++++++++++---- tests/eval.rkt | 1 + 3 files changed, 119 insertions(+), 15 deletions(-) diff --git a/printer.rkt b/printer.rkt index 72ab6ff..74febe1 100644 --- a/printer.rkt +++ b/printer.rkt @@ -114,13 +114,15 @@ (: ppr-node (-> Node ISeq)) (define (ppr-node a) (cond - [(integer? a) + [(integer-node? a) (iseq-append "NNum " (number->string a))] - [(not (eq? (car a) 'define)) - (let ([fun (first a)] - [arg (second a)]) + [(ap-node? a) + (let ([fun (ap-fun a)] + [arg (ap-arg a)]) (iseq-append "NAp " (ppr-addr fun) " " (ppr-addr arg)))] - [else (iseq-append "NSupercomb " (symbol->string (caadr a)))])) + [(sc-node? a) (iseq-append "NSupercomb " (symbol->string (caadr a)))] + [(indirect-node? a) (iseq-append "Indirect " (ppr-addr (indirect-addr a)))] + [else (error "Impossible: Undefined node encountered")])) (: ppr-stack-node (-> Heap Node ISeq)) (define (ppr-stack-node heap node) diff --git a/semantics.rkt b/semantics.rkt index c635436..14bd278 100644 --- a/semantics.rkt +++ b/semantics.rkt @@ -10,10 +10,51 @@ (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 (List 'Indirect Addr) 'Undef)) (define-type Globals (Immutable-HashTable Name Addr)) (define-type Stats Nonnegative-Integer) + +(: ap-node? (-> Node Boolean : (List Addr Addr))) +(define (ap-node? a) + (and (pair? a) (number? (car a)) (pair? (cdr a)) (null? (cddr a)))) + +(: undef-node? (-> Any Boolean : 'Undef)) +(define (undef-node? a) + (eqv? a 'Undef)) + +(: indirect-node? (-> Node Boolean : (List 'Indirect Addr))) +(define (indirect-node? a) + (and (pair? a) (eqv? (car a) 'Indirect))) + +(: indirect-node (-> Addr (∩ (List 'Indirect Addr) Node))) +(define (indirect-node a) + (list 'Indirect a)) + +(: integer-node? (-> Node Boolean : Integer)) +(define (integer-node? a) + (integer? a)) + +(: sc-node? (-> Node Boolean : CoreScDefn)) +(define (sc-node? a) + (and (pair? a) (eqv? (car a) 'define))) + +(: ap-fun (-> (List Addr Addr) Addr)) +(define (ap-fun a) + (first a)) + +(: ap-arg (-> (List Addr Addr) Addr)) +(define (ap-arg a) + (second a)) + +(: match-sc (-> CoreScDefn (Values (Listof Name) CoreExpr))) +(define (match-sc scdef) + (values (cdadr scdef) (caddr scdef))) + +(: indirect-addr (-> (List 'Indirect Addr) Addr)) +(define (indirect-addr a) + (second a)) + (: empty-heap Heap) (define empty-heap (treelist)) @@ -31,6 +72,10 @@ (: empty-stack Stack) (define empty-stack '()) +(: push-addr (-> Stack Addr (Pairof Addr Stack))) +(define (push-addr st n) + (cons n st)) + (: incr-stats (-> Stats Stats)) (define incr-stats add1) @@ -110,11 +155,15 @@ (: step-node (-> Stack State Node State)) (define (step-node rstack st n) - (match n - [(? integer?) (error "A number cannot be stepped any further!")] - [(list a _) (update-stack (λ (x) (cons a x)) st)] - [(list 'define (list name args ...) body) - (step-sc rstack st args body)])) + (cond + [(integer-node? n) (error "A number cannot be stepped any further!")] + [(ap-node? n) (update-stack (λ (stack) (push-addr stack (ap-fun n))) st)] + [(undef-node? n) (error "An undefined node is being stepped!")] + [(sc-node? n) + (let-values ([(args body) (match-sc n)]) + (step-sc rstack st args body))] + [(indirect-node? n) + (update-stack (λ (stack) (push-addr stack (indirect-addr n))) st)])) (: get-arg (-> Heap Addr Addr)) (define (get-arg heap addr) @@ -138,15 +187,26 @@ (: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr))) (define (instantiate-and-allocate e env heap) - (let ([res (instantiate e env heap)]) + (let ([res (instantiate-expr 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) +(: instantiate-and-assign (-> CoreExpr Globals Heap Addr Heap)) +(define (instantiate-and-assign e env heap addr) + (let ([res (instantiate-expr e env heap)]) + (cond + [(number? res) + (update-heap heap addr (list 'Indirect res))] + [else + (let ([heap (car res)] + [node (cdr res)]) + (update-heap heap addr node))]))) + +(: instantiate-expr (-> CoreExpr Globals Heap (∪ Addr (Pair Heap Node)))) +(define (instantiate-expr e env heap) (match e [(? integer?) (cons heap e)] [(list f a) @@ -156,9 +216,36 @@ [(? symbol?) (lookup-globals env e)] [(list 'let binds e) (let-values ([(env heap) (instantiate-binds binds env heap)]) - (instantiate e env heap))] + (instantiate-expr e env heap))] + [(list 'letrec binds e) + (let-values ([(env heap) (instantiate-rec-binds binds env heap)]) + (print heap) + (instantiate-expr e env heap))] [_ (error "unimplemented")])) +(: instantiate-rec-binds (-> CoreBinds Globals Heap (Values Globals Heap))) +(define (instantiate-rec-binds binds env heap) + (let-values ([(addrs env heap) + (for/fold + ([addrs : (Listof Addr) '()] + [env : Globals env] + [heap : Heap heap]) + ([bind : CoreBind binds]) + (let-values ([(heap addr) (allocate-node heap 'Undef)]) + (values (cons addr addrs) (update-globals env (first bind) addr) heap)))]) + (values env (for/fold + ([heap : Heap heap]) + ([bind : CoreBind binds] + [addr : Addr (reverse addrs)]) + (instantiate-rec-bind addr bind env heap))))) + +(: instantiate-rec-bind (-> Addr CoreBind Globals Heap Heap)) +(define (instantiate-rec-bind addr bind env heap) + (let ([x (first bind)] + [e (second bind)]) + (let ([heap (instantiate-and-assign e env heap addr)]) + heap))) + (: instantiate-binds (-> CoreBinds Globals Heap (Values Globals Heap))) (define (instantiate-binds binds old-env heap) (for/fold @@ -175,5 +262,19 @@ (values (update-globals new-env x addr) heap)))) +(define-type Unallocated-Node (Pair 'Unallocated Node)) + +(: unallocated-node-get (-> Unallocated-Node Node)) +(define (unallocated-node-get a) + (cdr a)) + +(: unallocated-node? (-> (∪ Addr Unallocated-Node) Boolean : Unallocated-Node)) +(define (unallocated-node? a) + (pair? a)) + +(: unallocated-node (-> Node Unallocated-Node)) +(define (unallocated-node a) + (cons 'Unallocated a)) + (provide (all-defined-out)) diff --git a/tests/eval.rkt b/tests/eval.rkt index 5dbf034..a8ed083 100644 --- a/tests/eval.rkt +++ b/tests/eval.rkt @@ -31,3 +31,4 @@ (check-equal? (exp-final-node (ap-exp 'K 100 99)) 100) (check-equal? (exp-final-node `(let ((x ,(ap-exp 'S 'K 'K 3)) (y 5)) ,(ap-exp 'K 'x 'x))) 3) (check-equal? (exp-final-node `(let ((x ,(ap-exp 'S 'K 'K 3)) (y 5)) ,(ap-exp 'K 'y 'x))) 5) +;; (check-equal? (exp-final-node `(letrec ((y x) (x ,(ap-exp 'S 'K 'K 3))) ,(ap-exp 'K 'y 'x))) 5)