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