21 |
fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s) |
fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s) |
22 |
val say = Control.Print.say |
val say = Control.Print.say |
23 |
|
|
24 |
|
datatype flintkind = FK_WRAP | FK_REIFY | FK_DEBRUIJN | FK_NAMED | FK_CPS |
25 |
|
|
26 |
fun phase x = Stats.doPhase (Stats.makePhase x) |
fun phase x = Stats.doPhase (Stats.makePhase x) |
27 |
|
|
28 |
val lcontract = phase "Compiler 052 lcontract" LContract.lcontract |
val lcontract = phase "Compiler 052 lcontract" LContract.lcontract |
29 |
val fcollect = phase "Compiler 052a fcollect" Collect.collect |
val fcollect = phase "Compiler 052a fcollect" Collect.collect |
30 |
val fcontract = phase "Compiler 052b fcontract" FContract.contract |
val fcontract = phase "Compiler 052b fcontract" FContract.contract |
31 |
val fcontract = fn f => (fcontract(fcollect f, Stats.newCounter[])) |
val fcontract = fn f => (fcontract(fcollect f, Stats.newCounter[])) |
|
|
|
32 |
val loopify = phase "Compiler 057 loopify" Loopify.loopify |
val loopify = phase "Compiler 057 loopify" Loopify.loopify |
33 |
|
val fixfix = phase "Compiler 056 fixfix" FixFix.fixfix |
34 |
|
|
35 |
|
val typelift = phase "Compiler 0535 typelift" Lift.typeLift |
36 |
|
val wformed = phase "Compiler 0536 wformed" Lift.wellFormed |
37 |
|
|
38 |
val specialize= phase "Compiler 053 specialize" Specialize.specialize |
val specialize= phase "Compiler 053 specialize" Specialize.specialize |
39 |
val wrapping = phase "Compiler 054 wrapping" Wrapping.wrapping |
val wrapping = phase "Compiler 054 wrapping" Wrapping.wrapping |
40 |
val reify = phase "Compiler 055 reify" Reify.reify |
val reify = phase "Compiler 055 reify" Reify.reify |
41 |
val fixfix = phase "Compiler 056 fixfix" FixFix.fixfix |
|
42 |
|
val deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names |
43 |
|
val names2deb = phase "Compiler 057 names2deb" TvarCvt.names2debIndex |
44 |
|
|
45 |
val convert = phase "Compiler 060 convert" Convert.convert |
val convert = phase "Compiler 060 convert" Convert.convert |
46 |
val cpstrans = phase "Compiler 065 cpstrans" CPStrans.cpstrans |
val cpstrans = phase "Compiler 065 cpstrans" CPStrans.cpstrans |
102 |
check (ChkFlint.checkTop, PPFlint.printFundec, |
check (ChkFlint.checkTop, PPFlint.printFundec, |
103 |
"FLINT") (CTRL.check, b, s) |
"FLINT") (CTRL.check, b, s) |
104 |
|
|
105 |
val fcing = ref (!fcs) |
fun wff (f, s) = if wformed f then () |
106 |
|
else print ("\nAfter " ^ s ^ " CODE NOT WELL FORMED\n") |
107 |
|
|
108 |
(* fun fcontract f = |
(* val fcing = ref (!fcs) |
109 |
|
fun fcontract f = |
110 |
case !fcing |
case !fcing |
111 |
of fcontract::fcs => (fcing := fcs; fcontract f) |
of fcontract::fcs => (fcing := fcs; fcontract f) |
112 |
| [] => let val fcc = Stats.newCounter[] |
| [] => let val fcc = Stats.newCounter[] |
130 |
(* f:FLINT.prog flint codee |
(* f:FLINT.prog flint codee |
131 |
* r:boot whether it has gone through reify yet |
* r:boot whether it has gone through reify yet |
132 |
* l:string last phase through which it went *) |
* l:string last phase through which it went *) |
133 |
fun runphase (p as "fcontract",(f,r,l)) = (fcontract f, r, p) |
fun runphase (p,(f,fk,l)) = |
134 |
| runphase (p as "lcontract",(f,r,l)) = (lcontract f, r, p) |
case (p,fk) |
135 |
| runphase (p as "fixfix",(f,r,l)) = (fixfix f, r, p) |
of (("fcontract" | "lcontract"), FK_DEBRUIJN) => |
136 |
| runphase (p as "loopify",(f,r,l)) = (loopify f, r, p) |
(say("\n!! "^p^" cannot be applied to the DeBruijn form !!\n"); |
137 |
| runphase (p as "wrap",(f,false,l)) = (wrapping f, false, p) |
(f, fk, l)) |
138 |
| runphase (p as "specialize",(f,false,l)) = (specialize f, false, p) |
|
139 |
| runphase (p as "reify",(f,false,l)) = (reify f, true, p) |
| ("fcontract",_) => (fcontract f, fk, p) |
140 |
|
| ("lcontract",_) => (lcontract f, fk, p) |
141 |
|
| ("fixfix", _) => (fixfix f, fk, p) |
142 |
|
| ("loopify", _) => (loopify f, fk, p) |
143 |
|
| ("specialize",FK_NAMED) => (specialize f, fk, p) |
144 |
|
| ("typelift",FK_DEBRUIJN) => (typelift f, fk, p) |
145 |
|
| ("wrap",FK_NAMED) => (wrapping f, FK_WRAP, p) |
146 |
|
| ("reify",FK_WRAP) => (reify f, FK_REIFY, p) |
147 |
|
| ("deb2names",FK_DEBRUIJN) => (deb2names f, FK_NAMED, p) |
148 |
|
| ("names2deb",FK_NAMED) => (names2deb f, FK_DEBRUIJN, p) |
149 |
|
|
150 |
(* pseudo FLINT phases *) |
(* pseudo FLINT phases *) |
151 |
| runphase ("id",(f,r,l)) = (f,r,l) |
| ("id",_) => (f,fk,l) |
152 |
| runphase (p as "collect",(f,r,l)) = (fcollect f, r, p) |
| ("collect",_) => (fcollect f, fk, p) |
153 |
| runphase (p as "print",(f,r,l)) = |
| ("print",_) => |
154 |
(say("\n[ After "^l^"... ]\n\n"); |
(say("\n\n[ After "^l^"... ]\n\n"); |
155 |
PPFlint.printFundec f; (f,r,l) |
PPFlint.printFundec f; |
156 |
before say "\n") |
(f, fk, l) before say "\n") |
157 |
| runphase ("check",(f,r,l)) = |
| ("wellformed",FK_DEBRUIJN) => (wff(f,l); (f,fk,p)) |
158 |
|
| ("check",_) => |
159 |
(check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT") |
(check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT") |
160 |
(ref true, r, l) f; (f,r,l)) |
(ref true, fk = FK_REIFY, l) f; (f,fk,l)) |
161 |
| runphase (p as ("reify"|"specialize"|"wrap"),(f,true,l)) = |
| _ => |
162 |
(say("\n"^p^"cannot be used after reify!\n"); (f,true,l)) |
(say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n"); |
163 |
| runphase (p,(f,r,l)) = |
(f,fk,l)) |
164 |
(say("\n!! Unknown FLINT phase '"^p^"' !!\n"); (f,r,l)) |
|
165 |
|
fun print (f,fk,l) = (prF l f; (f, fk, l)) |
166 |
fun print (f,r,l) = (prF l f; (f, r, l)) |
fun check (f,fk,l) = |
167 |
fun check (f,r,l) = (chkF (r, l) f; (f, r, l)) |
((* if fk <> FK_NAMED *) chkF (fk = FK_REIFY, l) (names2deb f) (* else f *); |
168 |
|
(f, fk, l)) |
169 |
|
|
170 |
fun runphase' (arg as (p,{1=f,...})) = |
fun runphase' (arg as (p,{1=f,...})) = |
171 |
(if !CTRL.printPhases then say("Phase "^p^"...") else (); |
(if !CTRL.printPhases then say("Phase "^p^"...") else (); |
176 |
raise x) |
raise x) |
177 |
|
|
178 |
(* the "id" phase is just added to do the print/check at the entrance *) |
(* the "id" phase is just added to do the print/check at the entrance *) |
179 |
val (flint,r,_) = foldl runphase' |
val (flint,fk,_) = foldl runphase' |
180 |
(flint,false,"flintnm") |
(flint, FK_DEBRUIJN, "flintnm") |
181 |
((* "id" :: *) !CTRL.phases) |
((* "id" :: *) !CTRL.phases) |
|
val flint = if r then flint else (say "\n!!Forgot reify!!\n"; reify flint) |
|
|
|
|
|
(* val _ = (chkF (false,"1") o prF "Translation/Normalization") flint *) |
|
|
(* val flint = (chkF (false,"2") o prF "Fcontract" o fcontract) flint *) |
|
|
|
|
|
(* val flint = *) |
|
|
(* if !Control.FLINT.specialize then *) |
|
|
(* (chkF (false,"3") o prF "Specialization" o specialize) flint *) |
|
|
(* else flint *) |
|
|
(* val flint = (chkF (false,"2") o prF "Fcontract" o fcontract) flint *) |
|
|
|
|
|
(* val flint = (chkF (false,"6") o prF "FixFix" o fixfix) flint *) |
|
|
(* val flint = (chkF (false,"2") o prF "Fcontract" o fcontract) flint *) |
|
|
|
|
|
(* val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint *) |
|
|
(* val flint = (chkF (true, "5") o prF "Reify" o reify) flint *) |
|
182 |
|
|
183 |
(* val flint = (chkF (true,"2") o prF "Fcontract" o fcontract) flint *) |
(* run any missing phases *) |
184 |
|
val (flint,fk) = |
185 |
|
if fk = FK_NAMED |
186 |
|
then (say "\n!!Forgot deb2names!!\n"; (deb2names flint, FK_DEBRUIJN)) |
187 |
|
else (flint,fk) |
188 |
|
val (flint,fk) = |
189 |
|
if fk = FK_DEBRUIJN |
190 |
|
then (say "\n!!Forgot wrap!!\n"; (wrapping flint, FK_WRAP)) |
191 |
|
else (flint,fk) |
192 |
|
val (flint,fk) = |
193 |
|
if fk = FK_WRAP |
194 |
|
then (say "\n!!Forgot reify!!\n"; (reify flint, FK_REIFY)) |
195 |
|
else (flint,fk) |
196 |
|
|
197 |
|
(* finish up with CPS *) |
198 |
val (nc0, ncn, dseg) = |
val (nc0, ncn, dseg) = |
199 |
let val function = convert flint |
let val function = convert flint |
200 |
val _ = prC "convert" function |
val _ = prC "convert" function |