6 | PAlias
of ident
* pattern
7 | PConstruct
of con
* pattern list
8 | PAliasD
of ident
* pattern
9 | PConstructD
of con
* pattern list
15 | Construct
of con
* exp list
16 | Case
of exp
* (pattern
* exp
) list
17 | Let
of ident
* exp
* exp
21 | ConstructD
of con
* exp list
22 | CaseD
of exp
* (pattern
* exp
) list
23 | LetD
of ident
* exp
* exp
28 Fun
of (value
-> value
)
29 | Con
of con
* value list
39 (* control operators
*)
40 (*********************)
42 (* toplevel resetMarker
*)
43 val metaCont
= ref (fn (x
: value
) => x
)
46 let val v
= thunk () in
51 let val mc
= !metaCont
in
53 (fn k
=> let (* new marker which restores old one
*)
54 val _
= metaCont
:= (fn v
=>
55 let val _
= metaCont
:= mc
in
56 SMLofNJ
.Cont
.throw k v
65 (fn k
=> abort (fn () => f
67 (fn () => SMLofNJ
.Cont
.throw k v
))))
69 (*********************)
72 exception UnboundVar
of ident
74 fun update r var value
= (var
, value
) :: r
76 fun lookup
[] var
= raise (UnboundVar var
)
77 |
lookup ((var
, value
) :: r
) var
' =
78 if var
= var
' then value
else lookup r var
'
80 (* pattern matcher
- binds variables
81 patterns are linear
and pairwise disjoint
*)
82 fun patterneq (p
, value
) r
=
84 PVar x
=> (update r x value
, true)
86 let val (r
', eq
) = patterneq (p
, value
) r
in
87 (update r
' x value
, eq
)
89 |
PConstruct (c
, ps
) =>
90 let val Con(c
', vs
) = value
92 val eq
= eq
andalso (List.length vs
= List.length ps
)
94 List.foldl (fn ((p
, v
), (r
', eq
')) =>
95 let val (r
'', eq
'') = patterneq (p
, v
) r
' in
96 (r
'', eq
'' andalso eq
')
97 end) (r
, eq
) (ListPair.zip (ps
, vs
))
101 let val count
= ref
0 in
102 (fn x
=> (count
:= !count
+ 1;
103 (x^
(Int.toString (!count
)))))
106 (* copies pattern
with fresh variables bound
in new environment
*)
107 fun generatePattern (r
, p
) =
110 let val xx
= gensym x
in
111 (update r
x (Code (Var xx
)), PVar xx
)
114 let val (r
', p
') = generatePattern (r
, p
)
117 (update r
x (Code (Var xx
)),
120 |
PConstructD (c
, ps
) =>
122 List.foldr (fn (p
, (r
, ps
)) =>
123 let val (r
', p
') = generatePattern (r
, p
) in
127 (r
, PConstruct (c
, ps
))
130 (* the specializer
*)
135 (* Specialization
of Static Stuff
- standard semantics
*)
136 |
Lam (x
, e
) => Fun (fn y
=> spec
e (update r x y
))
139 let val Fun ff
= spec f r
in
143 |
Construct (c
, es
) =>
144 let val vs
= List.map (fn e
=> spec e r
) es
in
148 |
Case (test
, cls
) =>
149 let val testv
= spec test r
150 (* exhaustive by restriction on patterns
*)
154 let val (r
', eq
) = patterneq (p
, testv
) r
in
155 if eq
then spec e r
' else loop cls
160 |
Let (x
, e1
, e2
) => let val v1
= spec e1 r
in spec
e2 (update r x v1
) end
162 (* Specialization
of Dynamic stuff
*)
164 let val xx
= gensym x
166 reset (fn () => spec
e (update r
x (Code (Var xx
))))
168 Code (Lam (xx
, body
))
172 let val Code ff
= spec f r
173 val Code aa
= spec a r
178 |
ConstructD (c
, es
) =>
179 let val es
' = List.map (fn e
=> let val Code v
= spec e r
182 Code (Construct (c
, es
'))
185 |
LetD (x
, e1
, e2
) =>
186 let val xx
= gensym x
in
188 let val Code e1
' = spec e1 r
190 reset (fn () => k (spec
e2 (update r
x (Code (Var xx
)))))
192 Code (Let (xx
, e1
', e2
'))
196 |
CaseD (test
, cls
) =>
198 let val Code testd
= spec test r
199 val newCls
= List.map (fn (p
, e
) =>
200 let val (r
', p
') = generatePattern(r
, p
)
201 val Code branch
= reset (fn () => k (spec e r
'))
206 Code (Case(testd
, newCls
))
209 (* first
-order lifting
*)
211 let val Con(c
, []) = spec e r
in
212 Code(Construct (c
, []))
215 fun specialize p
= spec p
[]
217 (* standard evaluation
*)
218 val sampleProg1
= Lam("q", App(Let("id",
219 App(Var
"q", Var
"q"),
223 val sampleProg2
= Lam("f", App(Lam("x",
225 [(PConstruct("True",[]),
226 Lam("x",Lam("y",Var
"x"))),
227 (PConstruct("False",[]),
228 Lam("x",Lam("y",Var
"y")))])),
231 (* partial evaluation
*)
232 val sampleProg1D
= LamD("q", App(LetD("id",
233 AppD(Var
"q", Var
"q"),
237 val sampleProg2D
= LamD("f", LamD("x",
239 [(PConstructD("True",[]),
240 Lam("z",LamD("y", Var
"z"))),
241 (PConstructD("False",[]),
242 Lam("z",LamD("y", Var
"y")))]),
247 let val v
= specialize p
248 in print(valueToString v
)
252 val v1
= specialize sampleProg1
253 val v2
= specialize sampleProg2
254 val v3
= specialize sampleProg1D
255 val v4
= specialize sampleProg2