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

Parent Directory | Revision Log

---

Revision 64 - (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 :			structure CGC = Control.CG
10 :			structure MachSpec = Gen.MachSpec
11 :			structure Convert = Convert(MachSpec)
12 :			structure CPStrans = CPStrans(MachSpec)
13 :			structure CPSopt = CPSopt(MachSpec)
14 :			structure NewClosure = NClosure(MachSpec)
15 :			structure Spill = Spill(MachSpec)
16 :			structure CpsSplit = CpsSplitFun (MachSpec)
17 :			in
18 :
19 :			val architecture = Gen.MachSpec.architecture
20 :			fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s)
21 :			val say = Control.Print.say
22 :
23 :			fun phase x = Stats.doPhase (Stats.makePhase x)
24 :
25 :	monnier	64	val collLexp = phase "Compiler 052 collect" (fn le => (Collect.collect le; le))
26 :			val fconLexp = phase "Compiler 052 fcontract" FContract.contract
27 :	monnier	16	val lconLexp = phase "Compiler 052 lcontract" LContract.lcontract
28 :			val specLexp = phase "Compiler 053 specLexp" Specialize.specialize
29 :			val wrapLexp = phase "Compiler 054 wrapLexp" Wrapping.wrapLexp
30 :	monnier	45	val wrapLexpN = phase "Compiler 054 wrapLexpN" WrappingNEW.wrapping
31 :	monnier	16	val ltyComp = phase "Compiler 055 ltyComp" Reify.ltyComp
32 :	monnier	45	val reify = phase "Compiler 055 ltyCompN" ReifyNEW.reify
33 :	monnier	16	val narrow = phase "Compiler 056 ltNarrow" LtNarrow.narrow
34 :			(* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *)
35 :
36 :			val convert = phase "Compiler 060 Convert" Convert.convert
37 :			val cpstrans = phase "Compiler 065 CPStrans" CPStrans.cpstrans
38 :			val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce
39 :			val closure = phase "Compiler 080 closure" NewClosure.closeCPS
40 :			val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix
41 :			val spill = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize
42 :			then phase "Compiler 100 spill" Spill.spill
43 :			else fn x => x
44 :			val limit = phase "Compiler 110 limit" Limit.nolimit
45 :			val codegen = phase "Compiler 120 cpsgen" Gen.codegen
46 :
47 :			fun prGen (flag,printE) s e =
48 :	monnier	64	(if !flag then (say ("\n\n[ After " ^ s ^ " ... ]\n\n"); printE e) else ();
49 :	monnier	16	e)
50 :
51 :			val prLexp = prGen (CGC.printLambda, MCprint.printLexp)
52 :	monnier	51	val prFlint = prGen (CGC.printFlint, PPFlint.printProg)
53 :	monnier	16	val prCps = prGen (CGC.printit, PPCps.printcps0)
54 :
55 :			(** compiling FLINT code into the binary machine code *)
56 :			fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =
57 :			let fun err severity s =
58 :			error (0,0) severity (concat["Real constant out of range: ",s,"\n"])
59 :
60 :			fun dumpTerm (printE, s, le) =
61 :			let val outS = TextIO.openAppend (src ^ s);
62 :			val saveOut = !Control.Print.out
63 :			fun done () =
64 :			(TextIO.closeOut outS; Control.Print.out := saveOut)
65 :			in Control.Print.out := {say = fn s => TextIO.output(outS,s),
66 :			flush = fn () => TextIO.flushOut outS};
67 :			printE le handle x => (done () handle _ => (); raise x);
68 :			done ()
69 :			end
70 :	league	59
71 :			(* checking for type errors in various phases. *)
72 :	monnier	16	fun check (checkE,printE,chkId) (enableChk,lvl,logId) e =
73 :			(if !enableChk andalso checkE (e,lvl) then
74 :	league	59	(dumpTerm (printE, "." ^ chkId ^ logId, e)
75 :			(* the following line will cause type errors to halt
76 :			* compilation. i'd rather let it continue. --league
77 :			*)
78 :			(* bug (chkId ^ " typing errors " ^ logId) *)
79 :			)
80 :	monnier	16	else ();
81 :			e)
82 :			val chkLexp = check (CheckLty.checkLty, MCprint.printLexp, "lambda")
83 :			val chkFlint = check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")
84 :
85 :	league	59	val _ = (chkFlint (CGC.checkFlint,1,"1") o prFlint "Translation") flint
86 :	monnier	16
87 :	monnier	64	val _ = (PPFlint.LVarString := Collect.LVarString)
88 :			val _ = (prFlint "Collect" o collLexp) flint
89 :
90 :	monnier	16	val flint =
91 :	monnier	64	(chkFlint (CGC.checkFlint,1,"2") o prFlint "Fcontract" o fconLexp)
92 :			flint
93 :
94 :			val _ = (PPFlint.LVarString := LambdaVar.lvarName)
95 :
96 :			val flint =
97 :	league	59	(chkFlint (CGC.checkFlint,1,"2") o prFlint "Lcontract" o lconLexp)
98 :	monnier	16	flint
99 :
100 :			val flint =
101 :			if !CGC.specialize then
102 :	league	59	(chkFlint (CGC.checkFlint,1,"3")
103 :	monnier	45	o prFlint "Specialization" o specLexp) flint
104 :	monnier	16	else flint
105 :
106 :	monnier	45	(*
107 :			(*** explicit FLINT checking phase ***)
108 :			val flint = chkFlint (ref true, 3, "3") flint
109 :
110 :			(*** check out the new wrapping function *)
111 :			val nflint1 = (prFlint "NewWrapping" o wrapLexpN) flint
112 :			val nflint2 = chkFlint (ref true, 4, "4") nflint1
113 :			val nflint3 =
114 :			(chkFlint (ref false, 5, "5") o prFlint "NewReify" o reify) nflint2
115 :			val nlambda = Flint2Lambda.transFundec(nflint3)
116 :			val nlambda =
117 :			(chkLexp (CGC.checklty1,21,"4") o prLexp "NarrowingN" o narrow) nlambda
118 :			val (nfunction,ntable) = convert nlambda
119 :			*)
120 :
121 :	monnier	16	val lambda =
122 :			(chkLexp (CGC.checklty1,1,"1")
123 :			o prLexp "Translation-To-Lambda"
124 :			o Flint2Lambda.transFundec)
125 :			flint
126 :
127 :			val lambda =
128 :			(chkLexp (CGC.checklty1,11,"2") o prLexp "Wrapping" o wrapLexp)
129 :			lambda
130 :
131 :			val lambda = (chkLexp (CGC.checklty1,21,"3") o ltyComp) lambda
132 :
133 :			val lambda =
134 :			(chkLexp (CGC.checklty1,21,"4") o prLexp "Narrowing" o narrow) lambda
135 :
136 :			(*
137 :			val lambda = (chkLexp (CGC.checklty2,21,"5") o lambdaopt) lambda
138 :			*)
139 :
140 :			val (function,table) = convert lambda
141 :	monnier	45	local exception ZZZ
142 :			in val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ)
143 :			end
144 :	monnier	16	val _ = prCps "convert" function
145 :
146 :			val function = (prCps "cpstrans" o cpstrans) function
147 :
148 :			val (function,table) =
149 :			if !CGC.cpsopt then cpsopt (function,table,NONE,false)
150 :			else (function,table)
151 :			val _ = prCps "cpsopt" function
152 :
153 :			fun gen function = let
154 :			val function = (prCps "closure" o closure) function
155 :			val carg = globalfix function
156 :			val carg = spill carg
157 :			val (carg, limit) = limit carg
158 :			in
159 :			codegen (carg, limit, err);
160 :			collect ()
161 :			end
162 :
163 :			val fun0 :: funn = CpsSplit.cpsSplit function
164 :			val c0 = gen fun0
165 :			val cn = map gen funn
166 :
167 :			in {c0=c0, cn=cn , name=ref (SOME src)}
168 :			end (* function flintcomp *)
169 :
170 :			val flintcomp = phase "Compiler 050 FLINTComp" flintcomp
171 :
172 :			end (* local *)
173 :			end (* structure FLINTComp *)

---

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