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