Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0