author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Wed, 16 Jan 2019 17:15:58 +0000 | |
changeset 438 | 1fe179d53161 |
parent 371 | 63ac603f9697 |
permissions | -rw-r--r-- |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1 |
#lang racket/base |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
2 |
;; Another restart. Started 2018-07-08. |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
3 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
4 |
(require racket/set) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
5 |
(require racket/match) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
6 |
(require racket/pretty) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
7 |
(require (only-in racket/list drop-right last partition append-map)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
8 |
(require (only-in racket/struct make-constructor-style-printer)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
9 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
10 |
(module+ test (require rackunit)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
11 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
12 |
(define-syntax-rule (record N (F ...) extra ...) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
13 |
(struct N (F ...) #:transparent extra ...)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
14 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
15 |
;; PE translates an input AST plus an Environment into an AbsVal, |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
16 |
;; while recording a sequential (!) *history* of named computations. |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
17 |
|
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
18 |
;; AST |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
19 |
(record Lit (value)) ;; (Lit RacketAtom) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
20 |
(record Prim (name handler)) ;; (Prim Symbol HandlerFun) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
21 |
(record Ref (id)) ;; (Ref Symbol) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
22 |
(record If (test true false)) ;; (If AST AST AST) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
23 |
(record Lambda (formals body)) ;; (Lambda (Listof Symbol) AST) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
24 |
(record Apply (rator rands)) ;; (Apply AST (Listof AST)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
25 |
(record Bind (formal init body)) ;; (Bind Symbol AST AST) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
26 |
(record Letrec (formals inits body)) ;; (Letrec (Listof Symbol) (Listof AST) AST) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
27 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
28 |
;; An AbsVal is an *abstract value*, one of |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
29 |
;; - (Unknown Symbol), for a completely unknown value whose |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
30 |
;; computation is named by Symbol in the history; |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
31 |
;; - (Runtime Symbol Description), for a partially- or |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
32 |
;; completely-known value whose computation is named by Symbol in the |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
33 |
;; history; or |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
34 |
;; - (Compiletime Description), for a completely-known value whose |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
35 |
;; computation does not and need not appear in the history. |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
36 |
;; |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
37 |
(record Unknown (reference)) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
38 |
(record Runtime (reference description)) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
39 |
(record Compiletime (description)) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
40 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
41 |
;; An Environment maps user-level variable names to abstract-values. |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
42 |
;; Environment = (Listof (Cons Symbol AbsVal)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
43 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
44 |
;; Description |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
45 |
(record Atom (value)) ;; (Atom RacketAtom) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
46 |
;; ... or Prim; or ... |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
47 |
(record Pair (car cdr)) ;; (Pair AbsVal AbsVal) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
48 |
(record Closure (formals body env)) ;; (Closure (Listof Symbol) AST Environment) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
49 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
50 |
;;--------------------------------------------------------------------------- |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
51 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
52 |
(define-match-expander Known |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
53 |
(syntax-rules () |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
54 |
[(_ desc) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
55 |
(or (Runtime _ desc) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
56 |
(Compiletime desc))])) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
57 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
58 |
(define (known? v) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
59 |
(or (Compiletime? v) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
60 |
(Runtime? v))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
61 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
62 |
(define (known-value v) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
63 |
(match v [(Known d) d])) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
64 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
65 |
(define (unatom v) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
66 |
(Atom-value (known-value v))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
67 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
68 |
;;--------------------------------------------------------------------------- |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
69 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
70 |
(define (parse exp) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
71 |
(let walk ((exp exp)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
72 |
(match exp |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
73 |
[(? symbol?) (Ref exp)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
74 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
75 |
[`(quote ,e) (Lit e)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
76 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
77 |
[`(when ,test ,es ...) (If (walk test) (walk `(begin ,@es)) (Lit (void)))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
78 |
[`(if ,test ,true ,false) (If (walk test) (walk true) (walk false))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
79 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
80 |
[`(cond (else ,es ...)) (walk `(begin ,@es))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
81 |
[`(cond (,test ,es ...) ,clauses ...) (walk `(if ,test (begin ,@es) (cond ,@clauses)))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
82 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
83 |
[`(lambda (,formals ...) ,body-exps ...) (Lambda formals (walk `(begin ,@body-exps)))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
84 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
85 |
[`(begin) (Lit (void))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
86 |
[`(begin ,e) (walk e)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
87 |
[`(begin ,e ,es ...) (walk `(let ((,(gensym 'ignored) ,e)) ,@es))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
88 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
89 |
[`(let ,(? symbol? name) ((,names ,inits) ...) ,es ...) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
90 |
(walk `(letrec ((,name (lambda ,names ,@es))) (,name ,@inits)))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
91 |
[`(let ((,names ,inits) ...) ,es ...) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
92 |
(walk `((lambda ,names ,@es) ,@inits))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
93 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
94 |
[`(let* () ,es ...) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
95 |
(walk `(begin ,@es))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
96 |
[`(let* ((,name ,init) ,more ...) ,es ...) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
97 |
(walk `(let ((,name ,init)) (let* ,more ,@es)))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
98 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
99 |
[`(letrec ((,names ,inits) ...) ,es ...) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
100 |
(if (null? names) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
101 |
(walk `(begin ,@es)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
102 |
(Letrec names (map walk inits) (walk `(begin ,@es))))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
103 |
|
371
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
104 |
[`(,rator ,rands ...) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
105 |
(Apply (walk rator) (map walk rands))] |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
106 |
|
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
107 |
[_ (Lit exp)]))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
108 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
109 |
;;--------------------------------------------------------------------------- |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
110 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
111 |
(define (free-names pexp) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
112 |
(match pexp |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
113 |
[(Lit _) (seteq)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
114 |
[(Prim _ _) (seteq)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
115 |
[(Ref id) (seteq id)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
116 |
[(If test true false) (set-union (free-names test) (free-names true) (free-names false))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
117 |
[(Lambda formals body) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
118 |
(set-subtract (free-names body) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
119 |
(list->seteq formals))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
120 |
[(Apply rator rands) (apply set-union (free-names rator) (map free-names rands))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
121 |
[(Bind formal init body) (set-union (set-remove (free-names body) formal) (free-names init))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
122 |
[(Letrec formals inits body) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
123 |
(set-subtract (apply set-union (free-names body) (map free-names inits)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
124 |
(list->seteq formals))])) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
125 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
126 |
;;--------------------------------------------------------------------------- |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
127 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
128 |
(define *globals* (make-hash)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
129 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
130 |
(define (extend-env env names inits) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
131 |
(append (for/list [(name names) (init inits)] (cons name (box init))) env)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
132 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
133 |
(define (lookup-env env name) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
134 |
(match (assq name env) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
135 |
[(cons _name (box absval)) absval] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
136 |
[#f (let loop ((hs (pe-history))) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
137 |
(match hs |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
138 |
['() |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
139 |
(unbox (hash-ref *globals* |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
140 |
name |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
141 |
(lambda () (error 'lookup-env "Unbound variable: ~v" name))))] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
142 |
[(cons h hs) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
143 |
(match (assq name h) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
144 |
[(list _name _pure-or-effect _ast absval) absval] |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
145 |
[#f (loop hs)])]))])) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
146 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
147 |
;;--------------------------------------------------------------------------- |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
148 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
149 |
;; pe-history : (Parameterof History) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
150 |
;; History = (Listof Era) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
151 |
;; Era = (Listof (List Symbol (U 'pure 'effect) AST AbsVal)) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
152 |
(define pe-history (make-parameter '())) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
153 |
|
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
154 |
(define (next-id base) (gensym base)) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
155 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
156 |
(define-syntax-rule (residualize expr) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
157 |
(parameterize ((pe-history (cons '() (pe-history)))) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
158 |
(define av expr) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
159 |
(define ast (codegen-absval av)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
160 |
(wrap-era (car (pe-history)) ast (free-names ast)))) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
161 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
162 |
(define (wrap-era h body outstanding) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
163 |
(match h |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
164 |
['() body] |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
165 |
[(cons (list id pure-or-effect ast av) h) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
166 |
(if (or (eq? pure-or-effect 'effect) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
167 |
(set-member? outstanding id)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
168 |
(let ((outstanding (set-remove (set-union (free-names ast) outstanding) id))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
169 |
(if (equal? body (Ref id)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
170 |
(wrap-era h ast outstanding) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
171 |
(wrap-era h (Bind id ast body) outstanding))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
172 |
(wrap-era h body (set-remove outstanding id)))])) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
173 |
|
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
174 |
(define-syntax-rule (emit pure-or-effect [id ast-expr] av-expr) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
175 |
(let ((ast ast-expr)) ;; `id` is NOT in scope for `ast-expr` |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
176 |
(define purity (match 'pure-or-effect ;; `pure-or-effect` must be a literal symbol |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
177 |
['pure 'pure] |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
178 |
['effect 'effect])) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
179 |
(or (historical-match purity ast) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
180 |
(let* ((id (next-id 'id)) ;; `id` must be a literal symbol |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
181 |
(av av-expr)) ;; `id` is in scope for `av-expr` |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
182 |
(emit* purity id ast av))))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
183 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
184 |
(define (historical-match purity ast) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
185 |
;; TODO: BUG re soundness likely: not enough alpha-renaming! |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
186 |
(and (eq? purity 'pure) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
187 |
(let search-histories ((hs (pe-history))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
188 |
(match hs |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
189 |
['() #f] |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
190 |
[(cons era hs) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
191 |
(let search-era ((era era)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
192 |
(match era |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
193 |
['() (search-histories hs)] |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
194 |
[(cons (list id 'pure (== ast) av) _) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
195 |
;; (pretty-write `(historical-match (sought ,ast) (found ,id ,av))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
196 |
av] |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
197 |
[(cons _ era) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
198 |
(search-era era)]))])))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
199 |
|
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
200 |
(define (emit* purity id ast av) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
201 |
(match-define (cons h hs) (pe-history)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
202 |
(define entry (list id purity ast av)) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
203 |
;; (D `(emitting ,entry)) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
204 |
(pe-history (cons (cons entry h) hs)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
205 |
av) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
206 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
207 |
(define (codegen-absval absval) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
208 |
(match absval |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
209 |
[(Unknown id) (Ref id)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
210 |
[(Runtime id _) (Ref id)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
211 |
[(Compiletime d) (codegen-desc d)])) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
212 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
213 |
(define (codegen-desc d) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
214 |
(match d |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
215 |
[(Atom v) (Lit v)] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
216 |
[(? Prim? p) p] |
343
4bda741f7519
Fix type error in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
342
diff
changeset
|
217 |
[(Pair a d) (Apply CONS-prim (map codegen-absval (list a d)))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
218 |
[(Closure formals body env) (Lambda formals body)])) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
219 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
220 |
(define INDENT (make-parameter 0)) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
221 |
(define noisy? #f) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
222 |
(define (D x) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
223 |
(when noisy? |
338 | 224 |
(display (make-string (INDENT) #\space)) |
225 |
(display x) |
|
226 |
(newline))) |
|
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
227 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
228 |
;; AST Environment -> AbsVal |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
229 |
(define (pe pexp env) |
338 | 230 |
(D `((pexp ,pexp) (env ,env))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
231 |
(parameterize ((INDENT (+ (INDENT) 2))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
232 |
(match pexp |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
233 |
[(Lit v) (Compiletime (Atom v))] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
234 |
[(Prim _ _) (Compiletime pexp)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
235 |
[(Ref id) (lookup-env env id)] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
236 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
237 |
[(If test true false) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
238 |
(match (pe test env) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
239 |
[(Known (Atom #f)) (pe false env)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
240 |
[(Known _) (pe true env)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
241 |
[(Unknown test-id) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
242 |
(emit pure |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
243 |
[if-id (If (Ref test-id) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
244 |
(residualize (pe true env)) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
245 |
(residualize (pe false env)))] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
246 |
(Unknown if-id))])] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
247 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
248 |
[(Lambda formals body) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
249 |
(define (non-global? id) (assq id env)) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
250 |
(define captured (filter non-global? (set->list (free-names pexp)))) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
251 |
;; This step is akin to allocating spill slots for actual |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
252 |
;; arguments. It takes the place of alpha-renaming, making sure |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
253 |
;; that we don't run into shadowing problems as seen in e.g. the |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
254 |
;; comment against `enough-alpha-renaming-exp` below. |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
255 |
(define captured-vals (for/list [(c captured)] |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
256 |
(emit pure [cap-id (Ref c)] |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
257 |
(match (lookup-env env c) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
258 |
[(? Compiletime? av) av] |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
259 |
[(Runtime _ d) (Runtime cap-id d)] |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
260 |
[(Unknown _) (Unknown cap-id)])))) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
261 |
(define cloenv (extend-env '() captured captured-vals)) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
262 |
(define new-body (residualize (pe body (extend-env cloenv formals (map Unknown formals))))) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
263 |
(define clo (Closure formals new-body cloenv)) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
264 |
(emit pure |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
265 |
[lam-id (codegen-desc clo)] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
266 |
(Runtime lam-id clo))] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
267 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
268 |
[(Apply rator rands) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
269 |
(define rator-v (pe rator env)) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
270 |
(define rands-vs (for/list [(rand rands)] (pe rand env))) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
271 |
(match rator-v |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
272 |
[(Known (Closure formals body cloenv)) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
273 |
(D `(--> closure body ,body)) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
274 |
(pe body (extend-env cloenv formals rands-vs))] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
275 |
[(Known (and prim (Prim _name handler))) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
276 |
(D `(--> prim ,_name ,@rands-vs)) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
277 |
(apply handler prim rands-vs)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
278 |
[(Unknown rator-id) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
279 |
(emit effect ;; conservative |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
280 |
[app-id (Apply (Ref rator-id) (map codegen-absval rands-vs))] |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
281 |
(Unknown app-id))])] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
282 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
283 |
[(Bind formal init body) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
284 |
(define init-v (pe init env)) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
285 |
(pe body (extend-env env |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
286 |
(list formal) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
287 |
;; v Use `emit*` to preserve this bind in the output. |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
288 |
;; TODO: Think harder about why this is required. |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
289 |
(list (emit* 'pure formal (codegen-absval init-v) init-v))))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
290 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
291 |
[(Letrec formals inits body) |
371
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
292 |
;; TODO: finish this. At the moment it's just a sketch of an |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
293 |
;; implementation, quite likely far off base. |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
294 |
(define stubenv (extend-env env formals (map Unknown formals))) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
295 |
(emit pure |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
296 |
[letrec-id (Letrec formals |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
297 |
(for/list [(init inits)] (residualize (pe init stubenv))) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
298 |
(residualize (pe body stubenv)))] |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
299 |
(Unknown letrec-id))]) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
300 |
)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
301 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
302 |
;;--------------------------------------------------------------------------- |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
303 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
304 |
(define (prim-app/pure prim . args) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
305 |
(emit pure |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
306 |
[app-id (Apply prim (map codegen-absval args))] |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
307 |
(Unknown app-id))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
308 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
309 |
(define (prim-app/effect prim . args) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
310 |
(emit effect |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
311 |
[app-id (Apply prim (map codegen-absval args))] |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
312 |
(Unknown app-id))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
313 |
|
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
314 |
(define (lift-residualize/pure f) |
338 | 315 |
(lambda (self . args) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
316 |
(if (andmap known? args) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
317 |
(Compiletime (Atom (apply f (map unatom args)))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
318 |
(apply prim-app/pure self args)))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
319 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
320 |
(define (lift-residualize/pure* f) |
338 | 321 |
(lambda (self . args) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
322 |
(if (andmap known? args) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
323 |
(Compiletime (Atom (apply f args))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
324 |
(apply prim-app/pure self args)))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
325 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
326 |
(define (lift-commutative-associative-binop/pure f identity) |
338 | 327 |
(lambda (self . vals) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
328 |
(define-values (known unknown) (partition known? vals)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
329 |
(define part-val (apply f (map unatom known))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
330 |
(define part (Compiletime (Atom part-val))) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
331 |
(cond [(null? unknown) part] |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
332 |
[(= identity part-val) (apply prim-app/pure self unknown)] |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
333 |
[else (apply prim-app/pure self part unknown)]))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
334 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
335 |
(define CONS-prim (Prim 'cons (lambda (self a d) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
336 |
(emit pure |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
337 |
[pair-id (Apply CONS-prim (map codegen-absval (list a d)))] |
338 | 338 |
(Runtime pair-id (Pair a d)))))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
339 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
340 |
(for-each (lambda (p) (hash-set! *globals* (Prim-name p) (box (Compiletime p)))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
341 |
(list |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
342 |
(Prim '+ (lift-commutative-associative-binop/pure + 0)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
343 |
(Prim '* (lift-commutative-associative-binop/pure * 1)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
344 |
(Prim '- (lift-residualize/pure -)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
345 |
(Prim '< (lift-residualize/pure <)) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
346 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
347 |
CONS-prim |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
348 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
349 |
(Prim 'null? (lift-residualize/pure* (match-lambda [(Known (Atom '())) #t] [_ #f]))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
350 |
(Prim 'pair? (lift-residualize/pure* (match-lambda [(Known (Pair _ _)) #t] [_ #f]))) |
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
351 |
|
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
352 |
(Prim 'error prim-app/effect) ;; strictly residualized |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
353 |
(Prim 'write prim-app/effect) ;; strictly residualized |
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
354 |
|
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
355 |
;; (Prim 'number? (lift-residualize* 'number? (lambda (x) (and (Lit? x) (number? (Lit-value x)))))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
356 |
;; (Prim 'zero? (lift-residualize 'zero? zero?)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
357 |
;; (Prim 'eq? (lambda (x y) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
358 |
;; (if (and (Lit? x) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
359 |
;; (Lit? y)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
360 |
;; (Lit (eq? (Lit-value x) (Lit-value y))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
361 |
;; (prim-app 'eq? x y)))) |
338 | 362 |
|
363 |
(Prim 'PRIMcar (lambda (self x) |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
364 |
(match x |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
365 |
[(Known (Pair a _)) a] |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
366 |
[_ (prim-app/pure self x)]))) |
338 | 367 |
(Prim 'PRIMcdr (lambda (self x) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
368 |
(match x |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
369 |
[(Known (Pair _ d)) d] |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
370 |
[_ (prim-app/pure self x)]))) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
371 |
)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
372 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
373 |
(define (extend-globals! entry) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
374 |
(match-define (list global-name global-source) entry) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
375 |
(parameterize ((pe-history (cons '() (pe-history)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
376 |
(match (pe (parse global-source) '()) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
377 |
[(Unknown _) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
378 |
(error 'extend-globals! "Global ~v produced unknown result" global-name)] |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
379 |
[(Known (? Closure? c)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
380 |
(when (not (set-empty? (free-names (codegen-desc c)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
381 |
(error 'extend-globals! "Global ~v produced non-empty closure: ~a" |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
382 |
global-name |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
383 |
(free-names (codegen-desc c)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
384 |
(hash-set! *globals* (car entry) (box (Runtime global-name c)))] |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
385 |
[(Known other) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
386 |
(error 'extend-globals! "Global ~v produced non-closure: ~v" global-name other)]))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
387 |
|
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
388 |
(for-each extend-globals! |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
389 |
(list |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
390 |
(list 'car '(lambda (x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
391 |
(if (pair? x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
392 |
(PRIMcar x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
393 |
(error "Not a pair in car" x)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
394 |
(list 'cdr '(lambda (x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
395 |
(if (pair? x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
396 |
(PRIMcdr x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
397 |
(error "Not a pair in cdr" x)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
398 |
|
371
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
399 |
(list 'reverse '(lambda (x) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
400 |
(let loop ((x x) (acc '())) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
401 |
(if (null? x) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
402 |
acc |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
403 |
(loop (cdr x) (cons (car x) acc)))))) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
404 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
405 |
;; (list 'fold '(lambda (f acc x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
406 |
;; #:filter (if (sval-known? f) 'unfold '(#f #f #f)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
407 |
;; (let loop ((x x) (acc acc)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
408 |
;; (if (null? x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
409 |
;; acc |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
410 |
;; (loop (cdr x) (f (car x) acc)))))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
411 |
;; (list 'fold-right '(lambda (f acc x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
412 |
;; #:filter (if (sval-known? f) 'unfold '(#f #f #f)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
413 |
;; (let loop ((x x)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
414 |
;; (if (null? x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
415 |
;; acc |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
416 |
;; (let ((head (car x))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
417 |
;; (f head (loop (cdr x)))))))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
418 |
;; (list 'list? '(lambda (xs) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
419 |
;; (let loop ((xs xs)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
420 |
;; (if (null? xs) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
421 |
;; #t |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
422 |
;; (if (pair? xs) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
423 |
;; (loop (cdr xs)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
424 |
;; #f))))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
425 |
;; (list 'map '(lambda (f x) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
426 |
;; #:filter 'unfold |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
427 |
;; (fold-right (lambda (v c) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
428 |
;; #:filter 'unfold |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
429 |
;; (cons (f v) c)) '() x))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
430 |
;; (list 'append '(lambda (a b) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
431 |
;; #:filter 'unfold |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
432 |
;; (fold-right cons b a))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
433 |
)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
434 |
|
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
435 |
;;--------------------------------------------------------------------------- |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
436 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
437 |
;; (require racket/trace) (trace pe) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
438 |
;; (set! noisy? #t) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
439 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
440 |
(module+ test |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
441 |
(define compose-exp |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
442 |
'(let ((compose (lambda (f g) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
443 |
(lambda (x) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
444 |
(f (g x)))))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
445 |
(compose (lambda (a) (* a 2)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
446 |
(lambda (b) (+ b 1))))) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
447 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
448 |
(define (reconstruct v) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
449 |
(match v |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
450 |
[(Lit v) |
341
53561f408220
Quote reconstructed s-exp for Lit AST node
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
339
diff
changeset
|
451 |
`(quote ,v)] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
452 |
[(Prim name _) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
453 |
(string->symbol (string-append "#%" (symbol->string name)))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
454 |
[(Ref id) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
455 |
id] |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
456 |
[(If test true false) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
457 |
`(if ,(reconstruct test) ,(reconstruct true) ,(reconstruct false))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
458 |
[(Lambda formals body) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
459 |
`(lambda ,formals ,(reconstruct body))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
460 |
[(Apply rator rands) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
461 |
`(,(reconstruct rator) ,@(map reconstruct rands))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
462 |
[(Bind formal init body) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
463 |
(reconstruct-binds (list (list formal (reconstruct init))) body)] |
371
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
464 |
[(Letrec formals inits body) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
465 |
`(letrec ,(for/list [(formal formals) (init inits)] |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
466 |
(list formal (reconstruct init))) |
63ac603f9697
Initial sketch of letrec support in pe3.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
352
diff
changeset
|
467 |
,(reconstruct body))] |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
468 |
)) |
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
469 |
|
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
470 |
(define (reconstruct-binds bs body) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
471 |
(match body |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
472 |
[(Bind formal init body) (reconstruct-binds (cons (list formal (reconstruct init)) bs) body)] |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
473 |
[_ `(let* ,(reverse bs) ,(reconstruct body))])) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
474 |
|
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
475 |
(define (T e) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
476 |
(define ast (residualize (time (pe (parse e) '())))) |
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
477 |
;; (pretty-display ast) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
478 |
(define r (reconstruct ast)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
479 |
r) |
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
480 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
481 |
(define add1-to-123-exp |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
482 |
'((lambda (x) (+ x 1)) 123)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
483 |
|
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
484 |
(define add1-to-123-exp1 |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
485 |
`(let ((c (lambda (f) (f 123)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
486 |
(c (lambda (x) (+ x 1))))) |
338 | 487 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
488 |
(define cdar-exp `(let ((p (cons 1 2))) (PRIMcdr (PRIMcar (cons p p))))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
489 |
(define cdar-exp1 `(let ((p (cons 1 2))) (cdr (car (cons p p))))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
490 |
(define cdar-exp2 `(lambda (p) (cdr (car (cons p p))))) |
339
3060617e6661
Failing test case to continue with
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
338
diff
changeset
|
491 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
492 |
(define curried-exp |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
493 |
'(lambda (do-something-with bb) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
494 |
((((lambda (a) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
495 |
(lambda (b) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
496 |
(lambda (c) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
497 |
(do-something-with a b c)))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
498 |
'aa) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
499 |
(bb)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
500 |
'cc))) |
348
a1f36b933a23
Repair pe3.rkt along lines suggested by pe3.hs
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
343
diff
changeset
|
501 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
502 |
(define curried-cps-exp |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
503 |
'(lambda (do-something-with bb) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
504 |
((lambda (k a) (k (lambda (k b) (k (lambda (k c) (do-something-with k a b c)))))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
505 |
(lambda (bf) (bf (lambda (cf) (cf (lambda (x) (begin x)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
506 |
'cc)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
507 |
(bb))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
508 |
'aa))) |
338 | 509 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
510 |
(define shrunk-curried-exp |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
511 |
'(lambda (bb) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
512 |
((lambda (k b) (k (lambda () b))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
513 |
(lambda (f) (f)) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
514 |
(bb)))) |
342
28f32b467e48
Refined example, pinpointing the problem, which is the hacky transfer of history information into the environment.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
341
diff
changeset
|
515 |
|
349
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
516 |
(define code-duplication-exp |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
517 |
'(lambda (f g h a b c) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
518 |
(let ((x (f a b c))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
519 |
(let ((y (g x x))) |
5c05a52a3bec
More pe3.rkt examples
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
348
diff
changeset
|
520 |
(h y y))))) |
350
94053a45beff
Small `if` pe3.rkt example
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
349
diff
changeset
|
521 |
|
94053a45beff
Small `if` pe3.rkt example
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
349
diff
changeset
|
522 |
(define unknown-if-with-computation |
94053a45beff
Small `if` pe3.rkt example
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
349
diff
changeset
|
523 |
'(lambda (p f g x) |
94053a45beff
Small `if` pe3.rkt example
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
349
diff
changeset
|
524 |
(if (p x) |
94053a45beff
Small `if` pe3.rkt example
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
349
diff
changeset
|
525 |
(f (g x)) |
94053a45beff
Small `if` pe3.rkt example
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
349
diff
changeset
|
526 |
(g (f x))))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
527 |
|
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
528 |
(define computation-duplication-exp |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
529 |
`(lambda (r) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
530 |
(let ((p (cons 1 2)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
531 |
(q (cons 1 2))) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
532 |
(write p) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
533 |
(write q) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
534 |
(write (car p)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
535 |
(write (car p)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
536 |
(write (car r)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
537 |
(write (car r)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
538 |
(cons p q)))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
539 |
|
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
540 |
;; 2018-07-11 12:00:26 Currently (T try-to-confuse-historical-match) yields: |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
541 |
;; (lambda (x) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
542 |
;; (lambda (x) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
543 |
;; (let* ((pair-id22441 (#%cons x '22))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
544 |
;; (#%cons pair-id22441 pair-id22441)))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
545 |
;; ... which is wrong, and which should be more like (note the renaming to x1!): |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
546 |
;; (lambda (x) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
547 |
;; (lambda (x1) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
548 |
;; (let* ((pair-id22500 (#%cons x '22)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
549 |
;; (pair-id22501 (#%cons x1 '22))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
550 |
;; (#%cons pair-id22500 pair-id22501)))) |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
551 |
;; |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
552 |
;; 2018-07-11 17:02:42 Fixed, I think, with the uses of `emit` in |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
553 |
;; `captured-vals` in the `Lambda` case of `pe`, producing output |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
554 |
;; like: |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
555 |
;; (lambda (x) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
556 |
;; (let* ((cap-id39848 x)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
557 |
;; (lambda (x) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
558 |
;; (let* ((pair-id39852 (#%cons cap-id39848 '22)) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
559 |
;; (pair-id39853 (#%cons x '22))) |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
560 |
;; (#%cons pair-id39852 pair-id39853))))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
561 |
(define try-to-confuse-historical-match |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
562 |
'(lambda (x) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
563 |
(let ((f (lambda () (cons x 22)))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
564 |
(lambda (x) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
565 |
(let ((g (lambda () (cons x 22)))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
566 |
(cons (f) (g))))))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
567 |
|
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
568 |
;; 2018-07-11 12:03:39 Currently (T enough-alpha-renaming-exp) yields: |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
569 |
;; (lambda (x) (lambda (x) x)) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
570 |
;; ... which is super wrong. |
352
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
571 |
;; |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
572 |
;; 2018-07-11 17:02:42 Fixed, I think, with the uses of `emit` in |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
573 |
;; `captured-vals` in the `Lambda` case of `pe`, producing output |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
574 |
;; like: |
64173b64ff33
Figure out an approach to something equivalent (?) to alpha-renaming
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
351
diff
changeset
|
575 |
;; (lambda (x) (let* ((cap-id39400 x)) (lambda (x) cap-id39400))) |
351
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
576 |
(define enough-alpha-renaming-exp |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
577 |
'(lambda (x) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
578 |
(let ((f (lambda () x))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
579 |
(lambda (x) (f))))) |
1deee19838ee
Experimental purity tracking in pe3.rkt; failing test cases (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
350
diff
changeset
|
580 |
|
337
725b2d768d02
New approach to partial evaluation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
581 |
) |