SCM Repository
Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
Parent Directory
|
Revision Log
Revision 259 - (view) (download)
1 : | monnier | 16 | (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *) |
2 : | (* flintcomp.sml *) | ||
3 : | |||
4 : | monnier | 251 | functor FLINTComp (structure Gen: MACHINE_GEN |
5 : | val collect: unit -> CodeObj.code_object) : CODEGENERATOR = | ||
6 : | monnier | 16 | struct |
7 : | |||
8 : | local structure CB = CompBasic | ||
9 : | monnier | 122 | (* structure CGC = Control.CG *) |
10 : | monnier | 16 | structure MachSpec = Gen.MachSpec |
11 : | structure Convert = Convert(MachSpec) | ||
12 : | structure CPStrans = CPStrans(MachSpec) | ||
13 : | structure CPSopt = CPSopt(MachSpec) | ||
14 : | monnier | 102 | structure Closure = Closure(MachSpec) |
15 : | monnier | 251 | structure Spill = SpillFn(MachSpec) |
16 : | monnier | 16 | structure CpsSplit = CpsSplitFun (MachSpec) |
17 : | monnier | 220 | structure CTRL = FLINT_Control |
18 : | structure PP = PPFlint | ||
19 : | structure LT = LtyExtern | ||
20 : | structure O = Option | ||
21 : | structure F = FLINT | ||
22 : | monnier | 16 | in |
23 : | |||
24 : | monnier | 251 | structure Machine = Gen |
25 : | monnier | 16 | val architecture = Gen.MachSpec.architecture |
26 : | fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s) | ||
27 : | monnier | 220 | val say = Control_Print.say |
28 : | monnier | 16 | |
29 : | monnier | 197 | datatype flintkind = FK_WRAP | FK_REIFY | FK_DEBRUIJN | FK_NAMED | FK_CPS |
30 : | |||
31 : | monnier | 16 | fun phase x = Stats.doPhase (Stats.makePhase x) |
32 : | |||
33 : | monnier | 202 | val deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names |
34 : | val names2deb = phase "Compiler 057 names2deb" TvarCvt.names2debIndex | ||
35 : | |||
36 : | val lcontract = phase "Compiler 052 lcontract" LContract.lcontract | ||
37 : | monnier | 216 | (* val lcontract' = phase "Compiler 052 lcontract'" LContract.lcontract *) |
38 : | monnier | 164 | val fcollect = phase "Compiler 052a fcollect" Collect.collect |
39 : | val fcontract = phase "Compiler 052b fcontract" FContract.contract | ||
40 : | monnier | 259 | val fcontract = fn opts => fcontract opts o fcollect |
41 : | monnier | 191 | val loopify = phase "Compiler 057 loopify" Loopify.loopify |
42 : | monnier | 197 | val fixfix = phase "Compiler 056 fixfix" FixFix.fixfix |
43 : | monnier | 191 | |
44 : | monnier | 216 | val split = phase "Compiler 058 split" FSplit.split |
45 : | |||
46 : | monnier | 197 | val typelift = phase "Compiler 0535 typelift" Lift.typeLift |
47 : | val wformed = phase "Compiler 0536 wformed" Lift.wellFormed | ||
48 : | |||
49 : | monnier | 71 | val specialize= phase "Compiler 053 specialize" Specialize.specialize |
50 : | val wrapping = phase "Compiler 054 wrapping" Wrapping.wrapping | ||
51 : | val reify = phase "Compiler 055 reify" Reify.reify | ||
52 : | monnier | 220 | val recover = phase "Compiler 05a recover" Recover.recover |
53 : | monnier | 16 | |
54 : | monnier | 71 | val convert = phase "Compiler 060 convert" Convert.convert |
55 : | val cpstrans = phase "Compiler 065 cpstrans" CPStrans.cpstrans | ||
56 : | monnier | 16 | val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce |
57 : | monnier | 102 | val litsplit = phase "Compiler 075 litsplit" Literals.litsplit |
58 : | monnier | 251 | val litToBytes = phase "Compiler 076 litToBytes" Literals.litToBytes |
59 : | monnier | 102 | val closure = phase "Compiler 080 closure" Closure.closeCPS |
60 : | monnier | 16 | val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix |
61 : | monnier | 251 | val spill = phase "Compiler 100 spill" Spill.spill |
62 : | monnier | 16 | val limit = phase "Compiler 110 limit" Limit.nolimit |
63 : | val codegen = phase "Compiler 120 cpsgen" Gen.codegen | ||
64 : | |||
65 : | monnier | 71 | (** pretty printing for the FLINT and CPS code *) |
66 : | val (prF, prC) = | ||
67 : | let fun prGen (flag,printE) s e = | ||
68 : | monnier | 102 | if !flag then (say ("\n[After " ^ s ^ " ...]\n\n"); printE e; |
69 : | say "\n"; e) | ||
70 : | monnier | 71 | else e |
71 : | monnier | 162 | in (prGen (CTRL.print, PPFlint.printProg), |
72 : | monnier | 122 | prGen (Control.CG.printit, PPCps.printcps0)) |
73 : | monnier | 71 | end |
74 : | monnier | 16 | |
75 : | monnier | 71 | (** writing out a term into a error output file *) |
76 : | fun dumpTerm (printE, s, le) = | ||
77 : | let val outS = TextIO.openAppend s; | ||
78 : | val saveOut = !Control.Print.out | ||
79 : | fun done () = | ||
80 : | (TextIO.closeOut outS; Control.Print.out := saveOut) | ||
81 : | in Control.Print.out := {say = fn s => TextIO.output(outS,s), | ||
82 : | flush = fn () => TextIO.flushOut outS}; | ||
83 : | printE le handle x => (done () handle _ => (); raise x); | ||
84 : | done () | ||
85 : | end (* function dumpTerm *) | ||
86 : | |||
87 : | monnier | 189 | val fcs : (FLINT.prog -> FLINT.prog) list ref = ref [] |
88 : | |||
89 : | monnier | 16 | (** compiling FLINT code into the binary machine code *) |
90 : | fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = | ||
91 : | let fun err severity s = | ||
92 : | error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) | ||
93 : | |||
94 : | monnier | 202 | fun check (checkE,printE,chkId) (lvl,logId) e = |
95 : | if checkE (e,lvl) then | ||
96 : | (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e); | ||
97 : | bug (chkId ^ " typing errors " ^ logId)) | ||
98 : | else () | ||
99 : | monnier | 197 | fun wff (f, s) = if wformed f then () |
100 : | else print ("\nAfter " ^ s ^ " CODE NOT WELL FORMED\n") | ||
101 : | |||
102 : | monnier | 220 | (* f:prog flint code |
103 : | * fi:prog opt inlinable approximation of f | ||
104 : | monnier | 213 | * fk:flintkind what kind of flint variant this is |
105 : | monnier | 162 | * l:string last phase through which it went *) |
106 : | monnier | 220 | fun runphase (p,(f,fi,fk,l)) = |
107 : | monnier | 197 | case (p,fk) |
108 : | of (("fcontract" | "lcontract"), FK_DEBRUIJN) => | ||
109 : | (say("\n!! "^p^" cannot be applied to the DeBruijn form !!\n"); | ||
110 : | monnier | 220 | (f, fi, fk, l)) |
111 : | monnier | 122 | |
112 : | monnier | 259 | | ("fcontract",_) => |
113 : | (fcontract {etaSplit=false, tfnInline=false} f, fi, fk, p) | ||
114 : | | ("fcontract+eta",_) => | ||
115 : | (fcontract {etaSplit=true, tfnInline=false} f, fi, fk, p) | ||
116 : | monnier | 220 | | ("lcontract",_) => (lcontract f, fi, fk, p) |
117 : | | ("fixfix", _) => (fixfix f, fi, fk, p) | ||
118 : | | ("loopify", _) => (loopify f, fi, fk, p) | ||
119 : | | ("specialize",FK_NAMED) => (specialize f, fi, fk, p) | ||
120 : | | ("wrap",FK_NAMED) => (wrapping f, fi, FK_WRAP, p) | ||
121 : | | ("reify",FK_WRAP) => (reify f, fi, FK_REIFY, p) | ||
122 : | | ("deb2names",FK_DEBRUIJN) => (deb2names f, fi, FK_NAMED, p) | ||
123 : | | ("names2deb",FK_NAMED) => (names2deb f, fi, FK_DEBRUIJN, p) | ||
124 : | monnier | 198 | | ("typelift", _) => |
125 : | monnier | 220 | let val f = typelift f |
126 : | in if !CTRL.check then wff(f, p) else (); (f, fi, fk, p) end | ||
127 : | | ("split", FK_NAMED) => | ||
128 : | let val (f,fi) = split f in (f, fi, fk, p) end | ||
129 : | monnier | 16 | |
130 : | monnier | 197 | (* pseudo FLINT phases *) |
131 : | monnier | 220 | | ("pickle", _) => |
132 : | (valOf(UnpickMod.unpickleFLINT(PickMod.pickleFLINT(SOME f))), | ||
133 : | UnpickMod.unpickleFLINT(PickMod.pickleFLINT fi), | ||
134 : | fk, p) | ||
135 : | | ("collect",_) => (fcollect f, fi, fk, p) | ||
136 : | monnier | 197 | | _ => |
137 : | monnier | 220 | ((case (p,fk) |
138 : | of ("id",_) => () | ||
139 : | | ("wellformed",_) => wff(f,l) | ||
140 : | | ("recover",_) => | ||
141 : | let val {getLty,...} = recover(f, fk = FK_REIFY) | ||
142 : | in CTRL.recover := (say o LT.lt_print o getLty o F.VAR) | ||
143 : | end | ||
144 : | | ("print",_) => | ||
145 : | (say("\n[After "^l^"...]\n\n"); PP.printFundec f; say "\n") | ||
146 : | | ("printsplit", _) => | ||
147 : | (say "[ splitted ]\n\n"; O.map PP.printFundec fi; say "\n") | ||
148 : | | ("check",_) => | ||
149 : | (check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT") | ||
150 : | (fk = FK_REIFY, l) f) | ||
151 : | | _ => | ||
152 : | say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n")); | ||
153 : | (f, fi, fk, l)) | ||
154 : | monnier | 162 | |
155 : | monnier | 220 | fun print (f,fi,fk,l) = (prF l f; (f, fi, fk, l)) |
156 : | fun check' (f,fi,fk,l) = | ||
157 : | let fun c n reified f = | ||
158 : | check (ChkFlint.checkTop, PPFlint.printFundec, n) | ||
159 : | (reified, l) (names2deb f) | ||
160 : | in if !CTRL.check then | ||
161 : | (c "FLINT" (fk = FK_REIFY) f; O.map (c "iFLINT" false) fi; ()) | ||
162 : | else (); | ||
163 : | (f, fi, fk, l) | ||
164 : | end | ||
165 : | monnier | 197 | |
166 : | monnier | 184 | fun runphase' (arg as (p,{1=f,...})) = |
167 : | monnier | 189 | (if !CTRL.printPhases then say("Phase "^p^"...") else (); |
168 : | monnier | 202 | ((check' o print o runphase) arg) before |
169 : | monnier | 189 | (if !CTRL.printPhases then say("..."^p^" Done.\n") else ())) |
170 : | handle x => (say ("\nwhile in "^p^" phase\n"); | ||
171 : | monnier | 185 | dumpTerm(PPFlint.printFundec,"FLINT.core", f); |
172 : | raise x) | ||
173 : | monnier | 163 | |
174 : | monnier | 220 | val (flint,fi,fk,_) = foldl runphase' |
175 : | (flint, NONE, FK_DEBRUIJN, "flintnm") | ||
176 : | ((* "id" :: *) "deb2names" :: !CTRL.phases) | ||
177 : | monnier | 162 | |
178 : | monnier | 197 | (* run any missing phases *) |
179 : | val (flint,fk) = | ||
180 : | monnier | 198 | if fk = FK_DEBRUIJN |
181 : | then (say "\n!!Forgot deb2names!!\n"; (deb2names flint, FK_NAMED)) | ||
182 : | monnier | 197 | else (flint,fk) |
183 : | val (flint,fk) = | ||
184 : | monnier | 198 | if fk = FK_NAMED |
185 : | monnier | 197 | then (say "\n!!Forgot wrap!!\n"; (wrapping flint, FK_WRAP)) |
186 : | else (flint,fk) | ||
187 : | val (flint,fk) = | ||
188 : | if fk = FK_WRAP | ||
189 : | then (say "\n!!Forgot reify!!\n"; (reify flint, FK_REIFY)) | ||
190 : | else (flint,fk) | ||
191 : | monnier | 162 | |
192 : | monnier | 197 | (* finish up with CPS *) |
193 : | monnier | 102 | val (nc0, ncn, dseg) = |
194 : | let val function = convert flint | ||
195 : | val _ = prC "convert" function | ||
196 : | monnier | 71 | val function = (prC "cpstrans" o cpstrans) function |
197 : | monnier | 162 | val function = cpsopt (function,NONE,false) |
198 : | monnier | 71 | val _ = prC "cpsopt" function |
199 : | monnier | 45 | |
200 : | monnier | 102 | val (function, dlit) = litsplit function |
201 : | monnier | 251 | val data = litToBytes dlit |
202 : | monnier | 102 | val _ = prC "cpsopt-code" function |
203 : | |||
204 : | monnier | 251 | (** NOTE: we should be passing the source-code name (src) to the |
205 : | ** code generator somehow (for the second argument to code object allocation). | ||
206 : | **) | ||
207 : | monnier | 71 | fun gen fx = |
208 : | let val fx = (prC "closure" o closure) fx | ||
209 : | val carg = globalfix fx | ||
210 : | val carg = spill carg | ||
211 : | val (carg, limit) = limit carg | ||
212 : | in codegen (carg, limit, err); | ||
213 : | collect () | ||
214 : | end | ||
215 : | monnier | 102 | |
216 : | monnier | 71 | in case CpsSplit.cpsSplit function |
217 : | monnier | 251 | of (fun0 :: funn) => (gen fun0, map gen funn, data) |
218 : | monnier | 71 | | [] => bug "unexpected case on gen in flintcomp" |
219 : | end | ||
220 : | monnier | 251 | in ({c0=nc0, cn=ncn, data=dseg}, fi) |
221 : | monnier | 16 | end (* function flintcomp *) |
222 : | |||
223 : | monnier | 71 | val flintcomp = phase "Compiler 050 flintcomp" flintcomp |
224 : | monnier | 16 | |
225 : | end (* local *) | ||
226 : | end (* structure FLINTComp *) | ||
227 : | monnier | 95 | |
228 : | (* | ||
229 : | monnier | 251 | * $Log: flintcomp.sml,v $ |
230 : | * Revision 1.8 1999/01/11 16:53:25 george | ||
231 : | * new array representation support | ||
232 : | * | ||
233 : | monnier | 95 | *) |
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |