22 |
|
|
23 |
fun phase x = Stats.doPhase (Stats.makePhase x) |
fun phase x = Stats.doPhase (Stats.makePhase x) |
24 |
|
|
25 |
val collLexp = phase "Compiler 052 collect" (fn le => (Collect.collect le; le)) |
val fcollect = phase "Compiler 052 collect" (fn le => (Collect.collect le; le)) |
26 |
val fconLexp = phase "Compiler 052 fcontract" FContract.contract |
val fcontract = phase "Compiler 052 fcontract" FContract.contract |
27 |
val lconLexp = phase "Compiler 052 lcontract" LContract.lcontract |
val lcontract = phase "Compiler 052 lcontract" LContract.lcontract |
28 |
val specLexp = phase "Compiler 053 specLexp" Specialize.specialize |
val specialize= phase "Compiler 053 specialize" Specialize.specialize |
29 |
val wrapLexp = phase "Compiler 054 wrapLexp" Wrapping.wrapLexp |
val wrapping = phase "Compiler 054 wrapping" Wrapping.wrapping |
30 |
val wrapLexpN = phase "Compiler 054 wrapLexpN" WrappingNEW.wrapping |
val reify = phase "Compiler 055 reify" Reify.reify |
|
val ltyComp = phase "Compiler 055 ltyComp" Reify.ltyComp |
|
|
val reify = phase "Compiler 055 ltyCompN" ReifyNEW.reify |
|
|
val narrow = phase "Compiler 056 ltNarrow" LtNarrow.narrow |
|
31 |
(* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *) |
(* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *) |
32 |
|
|
33 |
val convert = phase "Compiler 060 Convert" Convert.convert |
val convert = phase "Compiler 060 convert" Convert.convert |
34 |
val cpstrans = phase "Compiler 065 CPStrans" CPStrans.cpstrans |
val cpstrans = phase "Compiler 065 cpstrans" CPStrans.cpstrans |
35 |
val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce |
val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce |
36 |
val closure = phase "Compiler 080 closure" NewClosure.closeCPS |
val closure = phase "Compiler 080 closure" NewClosure.closeCPS |
37 |
val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix |
val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix |
41 |
val limit = phase "Compiler 110 limit" Limit.nolimit |
val limit = phase "Compiler 110 limit" Limit.nolimit |
42 |
val codegen = phase "Compiler 120 cpsgen" Gen.codegen |
val codegen = phase "Compiler 120 cpsgen" Gen.codegen |
43 |
|
|
|
fun prGen (flag,printE) s e = |
|
|
(if !flag then (say ("\n\n[ After " ^ s ^ " ... ]\n\n"); printE e) else (); |
|
|
e) |
|
|
|
|
|
val prLexp = prGen (CGC.printLambda, MCprint.printLexp) |
|
|
val prFlint = prGen (CGC.printFlint, PPFlint.printProg) |
|
|
val prCps = prGen (CGC.printit, PPCps.printcps0) |
|
44 |
|
|
45 |
(** compiling FLINT code into the binary machine code *) |
(** pretty printing for the FLINT and CPS code *) |
46 |
fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = |
val (prF, prC) = |
47 |
let fun err severity s = |
let fun prGen (flag,printE) s e = |
48 |
error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) |
if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e; e) |
49 |
|
else e |
50 |
|
in (prGen (CGC.printFlint, PPFlint.printProg), |
51 |
|
prGen (CGC.printit, PPCps.printcps0)) |
52 |
|
end |
53 |
|
|
54 |
|
(** writing out a term into a error output file *) |
55 |
fun dumpTerm (printE, s, le) = |
fun dumpTerm (printE, s, le) = |
56 |
let val outS = TextIO.openAppend (src ^ s); |
let val outS = TextIO.openAppend s; |
57 |
val saveOut = !Control.Print.out |
val saveOut = !Control.Print.out |
58 |
fun done () = |
fun done () = |
59 |
(TextIO.closeOut outS; Control.Print.out := saveOut) |
(TextIO.closeOut outS; Control.Print.out := saveOut) |
61 |
flush = fn () => TextIO.flushOut outS}; |
flush = fn () => TextIO.flushOut outS}; |
62 |
printE le handle x => (done () handle _ => (); raise x); |
printE le handle x => (done () handle _ => (); raise x); |
63 |
done () |
done () |
64 |
end |
end (* function dumpTerm *) |
65 |
|
|
66 |
|
(** compiling FLINT code into the binary machine code *) |
67 |
|
fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = |
68 |
|
let fun err severity s = |
69 |
|
error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) |
70 |
|
|
|
(* checking for type errors in various phases. *) |
|
71 |
fun check (checkE,printE,chkId) (enableChk,lvl,logId) e = |
fun check (checkE,printE,chkId) (enableChk,lvl,logId) e = |
72 |
(if !enableChk andalso checkE (e,lvl) then |
(if !enableChk andalso checkE (e,lvl) then |
73 |
(dumpTerm (printE, "." ^ chkId ^ logId, e) |
(dumpTerm (printE, src ^ "." ^ chkId ^ logId, e); |
74 |
(* the following line will cause type errors to halt |
bug (chkId ^ " typing errors " ^ logId)) |
|
* compilation. i'd rather let it continue. --league |
|
|
*) |
|
|
(* bug (chkId ^ " typing errors " ^ logId) *) |
|
|
) |
|
75 |
else (); |
else (); |
76 |
e) |
e) |
77 |
val chkLexp = check (CheckLty.checkLty, MCprint.printLexp, "lambda") |
fun chkF (b, s) = |
78 |
val chkFlint = check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT") |
check (ChkFlint.checkTop, PPFlint.printFundec, |
79 |
|
"FLINT") (CGC.checkFlint, b, s) |
|
val _ = (chkFlint (CGC.checkFlint,1,"1") o prFlint "Translation") flint |
|
|
|
|
|
val _ = (PPFlint.LVarString := Collect.LVarString) |
|
|
val _ = (prFlint "Collect" o collLexp) flint |
|
|
|
|
|
val flint = |
|
|
(chkFlint (CGC.checkFlint,1,"2") o prFlint "Fcontract" o fconLexp) |
|
|
flint |
|
|
|
|
|
val _ = (PPFlint.LVarString := LambdaVar.lvarName) |
|
|
|
|
|
val flint = |
|
|
(chkFlint (CGC.checkFlint,1,"2") o prFlint "Lcontract" o lconLexp) |
|
|
flint |
|
80 |
|
|
81 |
|
val _ = (chkF (false,"1") o prF "Translation") flint |
82 |
|
val flint = (chkF (false,"2") o prF "Lcontract" o lcontract) flint |
83 |
val flint = |
val flint = |
84 |
if !CGC.specialize then |
if !CGC.specialize then |
85 |
(chkFlint (CGC.checkFlint,1,"3") |
(chkF (false,"3") o prF "Specialization" o specialize) flint |
|
o prFlint "Specialization" o specLexp) flint |
|
86 |
else flint |
else flint |
87 |
|
|
88 |
(* |
val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint |
89 |
(*** explicit FLINT checking phase ***) |
val flint = (chkF (true, "5") o prF "Reify" o reify) flint |
90 |
val flint = chkFlint (ref true, 3, "3") flint |
val function = convert flint |
91 |
|
val (nc0, ncn) = |
92 |
(*** check out the new wrapping function *) |
let val _ = prC "convert" function |
93 |
val nflint1 = (prFlint "NewWrapping" o wrapLexpN) flint |
val function = (prC "cpstrans" o cpstrans) function |
|
val nflint2 = chkFlint (ref true, 4, "4") nflint1 |
|
|
val nflint3 = |
|
|
(chkFlint (ref false, 5, "5") o prFlint "NewReify" o reify) nflint2 |
|
|
val nlambda = Flint2Lambda.transFundec(nflint3) |
|
|
val nlambda = |
|
|
(chkLexp (CGC.checklty1,21,"4") o prLexp "NarrowingN" o narrow) nlambda |
|
|
val (nfunction,ntable) = convert nlambda |
|
|
*) |
|
|
|
|
|
val lambda = |
|
|
(chkLexp (CGC.checklty1,1,"1") |
|
|
o prLexp "Translation-To-Lambda" |
|
|
o Flint2Lambda.transFundec) |
|
|
flint |
|
|
|
|
|
val lambda = |
|
|
(chkLexp (CGC.checklty1,11,"2") o prLexp "Wrapping" o wrapLexp) |
|
|
lambda |
|
|
|
|
|
val lambda = (chkLexp (CGC.checklty1,21,"3") o ltyComp) lambda |
|
|
|
|
|
val lambda = |
|
|
(chkLexp (CGC.checklty1,21,"4") o prLexp "Narrowing" o narrow) lambda |
|
|
|
|
|
(* |
|
|
val lambda = (chkLexp (CGC.checklty2,21,"5") o lambdaopt) lambda |
|
|
*) |
|
|
|
|
|
val (function,table) = convert lambda |
|
94 |
local exception ZZZ |
local exception ZZZ |
95 |
in val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ) |
in |
96 |
|
val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ) |
97 |
end |
end |
|
val _ = prCps "convert" function |
|
|
|
|
|
val function = (prCps "cpstrans" o cpstrans) function |
|
|
|
|
98 |
val (function,table) = |
val (function,table) = |
99 |
if !CGC.cpsopt then cpsopt (function,table,NONE,false) |
if !CGC.cpsopt then cpsopt (function,table,NONE,false) |
100 |
else (function,table) |
else (function,table) |
101 |
val _ = prCps "cpsopt" function |
val _ = prC "cpsopt" function |
102 |
|
|
103 |
fun gen function = let |
fun gen fx = |
104 |
val function = (prCps "closure" o closure) function |
let val fx = (prC "closure" o closure) fx |
105 |
val carg = globalfix function |
val carg = globalfix fx |
106 |
val carg = spill carg |
val carg = spill carg |
107 |
val (carg, limit) = limit carg |
val (carg, limit) = limit carg |
108 |
in |
in codegen (carg, limit, err); |
|
codegen (carg, limit, err); |
|
109 |
collect () |
collect () |
110 |
end |
end |
111 |
|
in case CpsSplit.cpsSplit function |
112 |
val fun0 :: funn = CpsSplit.cpsSplit function |
of (fun0 :: funn) => (gen fun0, map gen funn) |
113 |
val c0 = gen fun0 |
| [] => bug "unexpected case on gen in flintcomp" |
114 |
val cn = map gen funn |
end |
115 |
|
in {c0=nc0, cn=ncn , name=ref (SOME src)} |
|
in {c0=c0, cn=cn , name=ref (SOME src)} |
|
116 |
end (* function flintcomp *) |
end (* function flintcomp *) |
117 |
|
|
118 |
val flintcomp = phase "Compiler 050 FLINTComp" flintcomp |
val flintcomp = phase "Compiler 050 flintcomp" flintcomp |
119 |
|
|
120 |
end (* local *) |
end (* local *) |
121 |
end (* structure FLINTComp *) |
end (* structure FLINTComp *) |