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