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 532 - (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 : dtelle 532 (* 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 : dtelle 532
29 : monnier 197 datatype flintkind = FK_WRAP | FK_REIFY | FK_DEBRUIJN | FK_NAMED | FK_CPS
30 : dtelle 532
31 : monnier 16 fun phase x = Stats.doPhase (Stats.makePhase x)
32 : dtelle 532
33 : monnier 202 val deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names
34 :     val names2deb = phase "Compiler 057 names2deb" TvarCvt.names2debIndex
35 : dtelle 532
36 : monnier 202 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 : dtelle 532 val switchoff = phase "Compiler unnumbered switchoff" Switchoff.switchoff
44 : monnier 216 val split = phase "Compiler 058 split" FSplit.split
45 : dtelle 532
46 : monnier 197 val typelift = phase "Compiler 0535 typelift" Lift.typeLift
47 :     val wformed = phase "Compiler 0536 wformed" Lift.wellFormed
48 : dtelle 532
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 : dtelle 532 | ("switchoff", _) => (
118 :     (*say("switchoff <-\n");*)
119 :     (*prF l f;*)
120 :     (*say("switchoff \n");
121 :     let val result = switchoff f
122 :     in
123 :     prF l result;
124 :     (result, fi, fk, p)
125 :     end*)
126 :     (switchoff f, fi, fk, p)
127 :     )
128 :     | ("fixfix", _) => (fixfix f, fi, fk, p)
129 : monnier 220 | ("loopify", _) => (loopify f, fi, fk, p)
130 :     | ("specialize",FK_NAMED) => (specialize f, fi, fk, p)
131 :     | ("wrap",FK_NAMED) => (wrapping f, fi, FK_WRAP, p)
132 :     | ("reify",FK_WRAP) => (reify f, fi, FK_REIFY, p)
133 :     | ("deb2names",FK_DEBRUIJN) => (deb2names f, fi, FK_NAMED, p)
134 :     | ("names2deb",FK_NAMED) => (names2deb f, fi, FK_DEBRUIJN, p)
135 : monnier 198 | ("typelift", _) =>
136 : monnier 220 let val f = typelift f
137 :     in if !CTRL.check then wff(f, p) else (); (f, fi, fk, p) end
138 :     | ("split", FK_NAMED) =>
139 :     let val (f,fi) = split f in (f, fi, fk, p) end
140 : monnier 16
141 : monnier 197 (* pseudo FLINT phases *)
142 : monnier 506 | ("pickle", _) =>
143 :     (valOf(UnpickMod.unpickleFLINT(#pickle(PickMod.pickleFLINT(SOME f)))),
144 :     UnpickMod.unpickleFLINT(#pickle(PickMod.pickleFLINT fi)),
145 :     fk, p)
146 : monnier 220 | ("collect",_) => (fcollect f, fi, fk, p)
147 : monnier 197 | _ =>
148 : monnier 220 ((case (p,fk)
149 :     of ("id",_) => ()
150 :     | ("wellformed",_) => wff(f,l)
151 :     | ("recover",_) =>
152 :     let val {getLty,...} = recover(f, fk = FK_REIFY)
153 :     in CTRL.recover := (say o LT.lt_print o getLty o F.VAR)
154 :     end
155 :     | ("print",_) =>
156 :     (say("\n[After "^l^"...]\n\n"); PP.printFundec f; say "\n")
157 :     | ("printsplit", _) =>
158 :     (say "[ splitted ]\n\n"; O.map PP.printFundec fi; say "\n")
159 :     | ("check",_) =>
160 :     (check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")
161 :     (fk = FK_REIFY, l) f)
162 :     | _ =>
163 :     say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n"));
164 :     (f, fi, fk, l))
165 : monnier 162
166 : monnier 220 fun print (f,fi,fk,l) = (prF l f; (f, fi, fk, l))
167 :     fun check' (f,fi,fk,l) =
168 :     let fun c n reified f =
169 :     check (ChkFlint.checkTop, PPFlint.printFundec, n)
170 :     (reified, l) (names2deb f)
171 :     in if !CTRL.check then
172 :     (c "FLINT" (fk = FK_REIFY) f; O.map (c "iFLINT" false) fi; ())
173 :     else ();
174 :     (f, fi, fk, l)
175 :     end
176 : monnier 197
177 : monnier 506 fun showhist [s] = say(concat[" raised at:\t", s, "\n"])
178 :     | showhist (s::r) = (showhist r; say (concat["\t\t", s, "\n"]))
179 :     | showhist [] = ()
180 :    
181 : monnier 184 fun runphase' (arg as (p,{1=f,...})) =
182 : monnier 189 (if !CTRL.printPhases then say("Phase "^p^"...") else ();
183 : monnier 202 ((check' o print o runphase) arg) before
184 : monnier 189 (if !CTRL.printPhases then say("..."^p^" Done.\n") else ()))
185 :     handle x => (say ("\nwhile in "^p^" phase\n");
186 : monnier 506 dumpTerm(PPFlint.printFundec,"flint.core", f);
187 :     showhist(SMLofNJ.exnHistory x);
188 : monnier 185 raise x)
189 : monnier 163
190 : monnier 220 val (flint,fi,fk,_) = foldl runphase'
191 :     (flint, NONE, FK_DEBRUIJN, "flintnm")
192 :     ((* "id" :: *) "deb2names" :: !CTRL.phases)
193 : monnier 162
194 : monnier 197 (* run any missing phases *)
195 :     val (flint,fk) =
196 : monnier 198 if fk = FK_DEBRUIJN
197 :     then (say "\n!!Forgot deb2names!!\n"; (deb2names flint, FK_NAMED))
198 : monnier 197 else (flint,fk)
199 :     val (flint,fk) =
200 : monnier 198 if fk = FK_NAMED
201 : monnier 197 then (say "\n!!Forgot wrap!!\n"; (wrapping flint, FK_WRAP))
202 :     else (flint,fk)
203 :     val (flint,fk) =
204 :     if fk = FK_WRAP
205 :     then (say "\n!!Forgot reify!!\n"; (reify flint, FK_REIFY))
206 :     else (flint,fk)
207 : monnier 162
208 : monnier 197 (* finish up with CPS *)
209 : monnier 102 val (nc0, ncn, dseg) =
210 :     let val function = convert flint
211 :     val _ = prC "convert" function
212 : monnier 71 val function = (prC "cpstrans" o cpstrans) function
213 : monnier 162 val function = cpsopt (function,NONE,false)
214 : monnier 71 val _ = prC "cpsopt" function
215 : monnier 45
216 : monnier 102 val (function, dlit) = litsplit function
217 : monnier 251 val data = litToBytes dlit
218 : monnier 102 val _ = prC "cpsopt-code" function
219 :    
220 : monnier 251 (** NOTE: we should be passing the source-code name (src) to the
221 :     ** code generator somehow (for the second argument to code object allocation).
222 :     **)
223 : monnier 71 fun gen fx =
224 :     let val fx = (prC "closure" o closure) fx
225 :     val carg = globalfix fx
226 :     val carg = spill carg
227 :     val (carg, limit) = limit carg
228 :     in codegen (carg, limit, err);
229 :     collect ()
230 :     end
231 : monnier 102
232 : monnier 71 in case CpsSplit.cpsSplit function
233 : monnier 251 of (fun0 :: funn) => (gen fun0, map gen funn, data)
234 : monnier 71 | [] => bug "unexpected case on gen in flintcomp"
235 :     end
236 : monnier 251 in ({c0=nc0, cn=ncn, data=dseg}, fi)
237 : monnier 16 end (* function flintcomp *)
238 :    
239 : monnier 71 val flintcomp = phase "Compiler 050 flintcomp" flintcomp
240 : monnier 16
241 :     end (* local *)
242 :     end (* structure FLINTComp *)
243 : monnier 95

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