131 lines
3.1 KiB
Racket
131 lines
3.1 KiB
Racket
#lang racket
|
|
|
|
#|
|
|
|
|
BUG: letrec & let are not handled properly by substitution
|
|
|
|
|#
|
|
|
|
(require redex "subst.ss")
|
|
|
|
(reduction-steps-cutoff 20)
|
|
|
|
(define-language lang
|
|
(p ((store (x v) ...) e))
|
|
(e (set! x e)
|
|
(let ((x e)) e)
|
|
(letrec ((x e)) e)
|
|
(begin e e ...)
|
|
(e e)
|
|
x
|
|
v)
|
|
(v (lambda (x) e)
|
|
number)
|
|
(x variable)
|
|
(pc ((store (x v) ...) ec))
|
|
(ec (ec e)
|
|
(v ec)
|
|
(set! variable ec)
|
|
(let ((x ec)) e)
|
|
(begin ec e e ...)
|
|
hole))
|
|
|
|
;; collect : term -> term
|
|
;; performs a garbage collection on the term `p'
|
|
(define (collect p)
|
|
(define (substitute var exp body)
|
|
(term-let ((var var)
|
|
(exp exp)
|
|
(body body))
|
|
(term (subst (var exp body)))))
|
|
|
|
(define (find-unused vars p)
|
|
(filter (λ (var) (unused? var p))
|
|
vars))
|
|
|
|
(define (unused? var p)
|
|
(let ([rhss (map cadr (cdar p))]
|
|
[body (cadr p)])
|
|
(and (not (free-in? var body))
|
|
(andmap (λ (rhs) (not (free-in? var rhs)))
|
|
rhss))))
|
|
|
|
(define (free-in? var body)
|
|
(not (equal? (substitute var (gensym) body)
|
|
body)))
|
|
|
|
(define (remove-unused vars p)
|
|
`((store ,@(filter (λ (binding) (not (memq (car binding) vars)))
|
|
(cdar p)))
|
|
,(cadr p)))
|
|
|
|
(let* ([vars (map car (cdar p))]
|
|
[unused (find-unused vars p)])
|
|
(cond
|
|
[(null? unused) p]
|
|
[else
|
|
(collect (remove-unused unused p))])))
|
|
|
|
(define reductions
|
|
(reduction-relation
|
|
lang
|
|
(==> (in-hole pc_1 (begin v e_1 e_2 ...))
|
|
(in-hole pc_1 (begin e_1 e_2 ...))
|
|
begin\ many)
|
|
|
|
(==> (in-hole pc_1 (begin e_1))
|
|
(in-hole pc_1 e_1)
|
|
begin\ one)
|
|
|
|
(==> ((store (x_before v_before) ...
|
|
(x_i v_i)
|
|
(x_after v_after) ...)
|
|
(in-hole ec_1 x_i))
|
|
((store
|
|
(x_before v_before) ...
|
|
(x_i v_i)
|
|
(x_after v_after) ...)
|
|
(in-hole ec_1 v_i))
|
|
deref)
|
|
|
|
(==> ((store (x_before v_before) ...
|
|
(x_i v)
|
|
(x_after v_after) ...)
|
|
(in-hole ec_1 (set! x_i v_new)))
|
|
((store (x_before v_before) ...
|
|
(x_i v_new)
|
|
(x_after v_after) ...)
|
|
(in-hole ec_1 v_new))
|
|
set!)
|
|
|
|
(==> (in-hole pc_1 ((lambda (x_1) e_1) v_1))
|
|
(in-hole pc_1 (subst (x_1 v_1 e_1)))
|
|
βv)
|
|
|
|
(==> ((store (name the-store any) ...)
|
|
(in-hole ec_1 (let ((x_1 v_1)) e_1)))
|
|
,(let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
|
|
(term
|
|
((store the-store ... (,new-x v_1))
|
|
(in-hole ec_1 (subst (x_1 ,new-x e_1))))))
|
|
let)
|
|
|
|
(==> (in-hole pc_1 (letrec ((x_1 e_1)) e_2))
|
|
(in-hole pc_1 (let ((x_1 0)) (begin (set! x_1 e_1) e_2)))
|
|
letrec)
|
|
|
|
with
|
|
[(--> a ,(collect (term b))) (==> a b)]))
|
|
|
|
(define (run e) (traces reductions `((store) ,e)))
|
|
|
|
(run '(letrec ((f (lambda (x)
|
|
(letrec ((y (f 1)))
|
|
2))))
|
|
(f 3)))
|
|
|
|
(run '(letrec ((f (lambda (x)
|
|
(letrec ((y 1))
|
|
(f 1)))))
|
|
(f 3)))
|