127 lines
4.2 KiB
Racket
127 lines
4.2 KiB
Racket
#lang typed/racket
|
||
(require "ast.rkt")
|
||
|
||
(: prelude CoreProgram)
|
||
(define prelude
|
||
'((define (I x) x) (define (K x y) x) (define (K1 x y) y) (define (S f g x) ((f x) (g x))) (define (compose f g x) (f (g x))) (define (twice f) ((compose f) f))))
|
||
|
||
(struct State ([stack : Stack] [dump : Dump] [heap : Heap] [globals : Globals] [stats : Stats]))
|
||
(define-type Addr Symbol)
|
||
(define-type Stack (Listof Addr))
|
||
(define-type Dump Null)
|
||
(define-type Heap (Immutable-HashTable Addr Node))
|
||
(define-type Node (∪ (List Addr Addr) CoreScDefn Integer))
|
||
(define-type Globals (Immutable-HashTable Name Addr))
|
||
(define-type Stats Nonnegative-Integer)
|
||
|
||
(: empty-heap Heap)
|
||
(define empty-heap
|
||
(make-immutable-hash))
|
||
|
||
(: empty-globals Globals)
|
||
(define empty-globals
|
||
(make-immutable-hash))
|
||
|
||
(: new-addr (-> Addr))
|
||
(define (new-addr)
|
||
(gensym))
|
||
|
||
(: empty-dump Dump)
|
||
(define empty-dump '())
|
||
|
||
(: empty-stats Stats)
|
||
(define empty-stats 0)
|
||
|
||
(: empty-stack Stack)
|
||
(define empty-stack '())
|
||
|
||
(: incr-stats (-> Stats Stats))
|
||
(define incr-stats add1)
|
||
|
||
(: update-globals (-> Globals Name Addr Globals))
|
||
(define (update-globals globals name addr)
|
||
(hash-set globals name addr))
|
||
|
||
(: update-stats (-> (-> Stats Stats) State State))
|
||
(define (update-stats f mstate)
|
||
(struct-copy State mstate [stats (f (State-stats mstate))]))
|
||
|
||
(: update-stack (-> (-> Stack Stack) State State))
|
||
(define (update-stack f mstate)
|
||
(struct-copy State mstate [stack (f (State-stack mstate))]))
|
||
|
||
(: allocate-node (-> Heap Node (Values Heap Addr)))
|
||
(define (allocate-node heap node)
|
||
(let ([addr (new-addr)])
|
||
(values (hash-set heap addr node) addr)))
|
||
|
||
(: lookup-node (-> Heap Addr Node))
|
||
(define lookup-node hash-ref)
|
||
|
||
(: lookup-globals (-> Globals Name Addr))
|
||
(define lookup-globals hash-ref)
|
||
|
||
(: initialize-heap (-> (Listof CoreScDefn) (Values Heap Globals)))
|
||
(define (initialize-heap scs)
|
||
(for/fold ([heap : Heap empty-heap]
|
||
[globals : Globals empty-globals])
|
||
([sc : CoreScDefn scs])
|
||
(let-values ([(new-heap addr) (allocate-node heap sc)])
|
||
(values new-heap
|
||
(update-globals globals (scdefn-name sc) addr)))))
|
||
|
||
(: compile-core (-> (Listof CoreScDefn) State))
|
||
(define (compile-core scdefs)
|
||
(let-values ([(heap globals) (initialize-heap (append scdefs prelude))])
|
||
(State (list (lookup-globals globals 'main)) empty-dump heap globals empty-stats)))
|
||
|
||
|
||
(: data-node? (-> Node Boolean))
|
||
(define data-node? integer?)
|
||
|
||
(: final-state? (-> State Boolean))
|
||
(define (final-state? st)
|
||
(match (State-stack st)
|
||
[(list n) (data-node? (lookup-node (State-heap st) n))]
|
||
[_ #f]))
|
||
|
||
(: step (-> State State))
|
||
(define (step state)
|
||
(let ([stack (State-stack state)])
|
||
(match stack
|
||
[(cons addr rstack)
|
||
(step-node rstack state (lookup-node (State-heap state) addr))]
|
||
['() (error "Invalid state")])))
|
||
|
||
(: 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)]))
|
||
|
||
(: 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 (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])))))
|
||
|
||
(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr)))
|
||
(define (instantiate-body e env heap)
|
||
(match e
|
||
[(? integer?) (allocate-node heap 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))]
|
||
[_ (error "unimplemented")]))
|