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