SCM Repository
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 |