Add in-place update

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))
+    [(ap-node? a)
-     (let ([fun (first a)]
+     (let ([fun (ap-fun a)]
-           [arg (second 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)

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,9 +72,24 @@
 (: 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)
 
+(: 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))
+
+
 (: update-globals (-> Globals Name Addr Globals))
 (define (update-globals globals name addr)
   (hash-set globals name addr))
@@ -94,16 +150,20 @@
   (let ([stack (State-stack state)])
     (match stack
       [(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")])))
 
-(: 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)
-  (match n
+  (cond
-    [(? integer?) (error "A number cannot be stepped any further!")]
+    [(integer-node? n) (error "A number cannot be stepped any further!")]
-    [(list a _) (update-stack (λ (x) (cons a x)) st)]
+    [(ap-node? n) (update-stack (λ (stack) (push-addr stack (ap-fun n))) st)]
-    [(list 'define (list name args ...) body)
+    [(undef-node? n) (error "An undefined node is being stepped!")]
-     (step-sc rstack st args body)]))
+    [(sc-node? n)
+     (let-values ([(args body) (match-sc n)])
+       (step-sc addr rstack st args body))]
+    [(indirect-node? n)
+     (update-stack (λ (_) (push-addr rstack (indirect-addr n))) st)]))
 
 (: get-arg (-> Heap Addr Addr))
 (define (get-arg heap addr)
@@ -111,34 +171,79 @@
     [(list _ a) a]
     [_ (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*-values ([(new-env new-stack)
+    (let*-values ([(new-env new-stack root)
                   (for/fold ([globals : Globals (State-globals state)]
-                             [stack : Stack rstack])
+                             [stack : Stack rstack]
+                             [root : Addr root])
                             ([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))))]
+                        (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack) (car stack))))])
-                  [(new-heap addr) (instantiate-body 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 new-heap])))))
+        (struct-copy State state [stack new-stack] [heap heap])))))
 
-(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr)))
+(: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr)))
-(define (instantiate-body e env heap)
+(define (instantiate-and-allocate e env heap)
+  (let-values ([(heap addr-or-node) (instantiate-expr e env heap)])
+    (cond
+      [(allocated-addr? addr-or-node)
+       (values heap addr-or-node)]
+      [else
+       (allocate-node heap (unallocated-node-get addr-or-node))])))
+
+(: instantiate-and-assign (-> CoreExpr Globals Heap Addr Heap))
+(define (instantiate-and-assign e env heap addr)
+  (let-values ([(heap addr-or-node) (instantiate-expr e env heap)])
+    (cond
+      [(allocated-addr? addr-or-node)
+       (update-heap heap addr (indirect-node addr-or-node))]
+      [else
+       (update-heap heap addr (unallocated-node-get addr-or-node))])))
+
+(: instantiate-expr (-> CoreExpr Globals Heap (Values Heap (∪ Addr Unallocated-Node))))
+(define (instantiate-expr e env heap)
   (match e
-    [(? integer?) (allocate-node heap e)]
+    [(? integer?) (values heap (unallocated-node e))]
     [(list f a)
-     (let*-values ([(heap0 addr-f) (instantiate-body f env heap)]
+     (let*-values ([(heap addr-f) (instantiate-and-allocate f env heap)]
-                   [(heap1 addr-a) (instantiate-body a env heap0)])
+                   [(heap addr-a) (instantiate-and-allocate a env heap)])
-       (allocate-node heap1 (list addr-f addr-a)))]
+       (values heap (unallocated-node (list addr-f addr-a))))]
     [(? symbol?) (values heap (lookup-globals env e))]
     [(list 'let binds e)
      (let-values ([(env heap) (instantiate-binds binds env heap)])
-       (instantiate-body e env heap))]
+       (instantiate-expr e env heap))]
+    [(list 'letrec binds e)
+     (let-values ([(env heap) (instantiate-rec-binds binds env 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
@@ -151,9 +256,26 @@
 (define (instantiate-bind bind old-env new-env heap)
   (let ([x (first bind)]
         [e (second bind)])
-    (let-values ([(heap addr) (instantiate-body e old-env heap)])
+    (let*-values ([(heap addr) (instantiate-and-allocate e old-env heap)])
       (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))
+
+(: allocated-addr? (-> (∪ Addr Unallocated-Node) Boolean : Addr))
+(define (allocated-addr? a)
+  (number? a))
+
+(: unallocated-node (-> Node Unallocated-Node))
+(define (unallocated-node a)
+  (cons 'Unallocated a))
 
 (provide (all-defined-out))

tests/eval.rkt

@@ -1,6 +1,7 @@
 #lang typed/racket
 (require "../semantics.rkt")
 (require "../ast.rkt")
+(require "../printer.rkt")
 (require typed/rackunit)
 
 (: exp->program (-> CoreExpr CoreProgram))
@@ -26,7 +27,17 @@
 (define (exp-final-node e)
   (program-final-node (exp->program e)))
 
+(define rec-program
+  '((define (pair x y f) ((f x) y))
+    (define (fst p) (p K))
+    (define (snd p) (p K1))
+    (define (f x y)
+      (letrec ((a ((pair x) b)) (b ((pair y) a))) (fst (snd (snd (snd a))))))
+    (define (main) ((f 3) 4))))
+
 (check-equal? (exp-final-node (ap-exp 'S 'K 'K 3)) 3)
 (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))) 3)
+(check-equal? (program-final-node rec-program) 4)

typed-parser.rkt

@@ -1,7 +1,25 @@
 #lang typed/racket
 (require "ast.rkt")
+(require racket/cmdline)
 (require/typed "parser.rkt"
   [parse-from-port (-> Input-Port CoreProgram)]
   [parse-from-string (-> String CoreProgram)])
 
+
+
+(module* main #f
+  (: filename Path-String)
+  (define filename
+    (let ([result (command-line
+                   #:program "core-parser"
+                   #:args (filename)
+                   filename)])
+      (if (path-string? result)
+          result
+          (error "Commandline parser returned unexpected results"))))
+
+
+  (pretty-print (parse-from-port
+                 (open-input-file filename))))
+
 (provide parse-from-port parse-from-string)