SCM Repository
Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
Parent Directory
|
Revision Log
Revision 102 - (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 : | monnier | 102 | structure Closure = Closure(MachSpec) |
15 : | monnier | 16 | 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 | 71 | val fcollect = phase "Compiler 052 collect" (fn le => (Collect.collect le; le)) |
26 : | monnier | 84 | (* val fcontract = phase "Compiler 052 fcontract" FContract.contract *) |
27 : | monnier | 71 | val lcontract = phase "Compiler 052 lcontract" LContract.lcontract |
28 : | val specialize= phase "Compiler 053 specialize" Specialize.specialize | ||
29 : | val wrapping = phase "Compiler 054 wrapping" Wrapping.wrapping | ||
30 : | val reify = phase "Compiler 055 reify" Reify.reify | ||
31 : | monnier | 16 | (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *) |
32 : | |||
33 : | monnier | 71 | val convert = phase "Compiler 060 convert" Convert.convert |
34 : | val cpstrans = phase "Compiler 065 cpstrans" CPStrans.cpstrans | ||
35 : | monnier | 16 | val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce |
36 : | monnier | 102 | val litsplit = phase "Compiler 075 litsplit" Literals.litsplit |
37 : | val lit2cps = phase "Compiler 076 lit2cps" Literals.lit2cps | ||
38 : | val closure = phase "Compiler 080 closure" Closure.closeCPS | ||
39 : | monnier | 16 | val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix |
40 : | val spill = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize | ||
41 : | then phase "Compiler 100 spill" Spill.spill | ||
42 : | else fn x => x | ||
43 : | val limit = phase "Compiler 110 limit" Limit.nolimit | ||
44 : | val codegen = phase "Compiler 120 cpsgen" Gen.codegen | ||
45 : | |||
46 : | monnier | 102 | val closureD = phase "Compiler 081 closureD" Closure.closeCPS |
47 : | val globalfixD= phase "Compiler 091 globalfixD" GlobalFix.globalfix | ||
48 : | val spillD = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize | ||
49 : | then phase "Compiler 101 spillD" Spill.spill | ||
50 : | else fn x => x | ||
51 : | val limitD = phase "Compiler 110 limitD" Limit.nolimit | ||
52 : | val codegenD = phase "Compiler 121 cpsgenD" Gen.codegen | ||
53 : | monnier | 16 | |
54 : | monnier | 71 | (** pretty printing for the FLINT and CPS code *) |
55 : | val (prF, prC) = | ||
56 : | let fun prGen (flag,printE) s e = | ||
57 : | monnier | 102 | if !flag then (say ("\n[After " ^ s ^ " ...]\n\n"); printE e; |
58 : | say "\n"; e) | ||
59 : | monnier | 71 | else e |
60 : | in (prGen (CGC.printFlint, PPFlint.printProg), | ||
61 : | prGen (CGC.printit, PPCps.printcps0)) | ||
62 : | end | ||
63 : | monnier | 16 | |
64 : | monnier | 71 | (** writing out a term into a error output file *) |
65 : | fun dumpTerm (printE, s, le) = | ||
66 : | let val outS = TextIO.openAppend s; | ||
67 : | val saveOut = !Control.Print.out | ||
68 : | fun done () = | ||
69 : | (TextIO.closeOut outS; Control.Print.out := saveOut) | ||
70 : | in Control.Print.out := {say = fn s => TextIO.output(outS,s), | ||
71 : | flush = fn () => TextIO.flushOut outS}; | ||
72 : | printE le handle x => (done () handle _ => (); raise x); | ||
73 : | done () | ||
74 : | end (* function dumpTerm *) | ||
75 : | |||
76 : | monnier | 16 | (** compiling FLINT code into the binary machine code *) |
77 : | fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = | ||
78 : | let fun err severity s = | ||
79 : | error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) | ||
80 : | |||
81 : | fun check (checkE,printE,chkId) (enableChk,lvl,logId) e = | ||
82 : | (if !enableChk andalso checkE (e,lvl) then | ||
83 : | monnier | 71 | (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e); |
84 : | bug (chkId ^ " typing errors " ^ logId)) | ||
85 : | monnier | 16 | else (); |
86 : | e) | ||
87 : | monnier | 71 | fun chkF (b, s) = |
88 : | check (ChkFlint.checkTop, PPFlint.printFundec, | ||
89 : | "FLINT") (CGC.checkFlint, b, s) | ||
90 : | monnier | 16 | |
91 : | monnier | 102 | val _ = (chkF (false,"1") o prF "Translation/Normalization") flint |
92 : | monnier | 71 | val flint = (chkF (false,"2") o prF "Lcontract" o lcontract) flint |
93 : | monnier | 16 | val flint = |
94 : | if !CGC.specialize then | ||
95 : | monnier | 71 | (chkF (false,"3") o prF "Specialization" o specialize) flint |
96 : | monnier | 16 | else flint |
97 : | |||
98 : | monnier | 71 | val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint |
99 : | val flint = (chkF (true, "5") o prF "Reify" o reify) flint | ||
100 : | monnier | 102 | |
101 : | val (nc0, ncn, dseg) = | ||
102 : | let val function = convert flint | ||
103 : | val _ = prC "convert" function | ||
104 : | monnier | 71 | val function = (prC "cpstrans" o cpstrans) function |
105 : | monnier | 102 | val function = |
106 : | if !CGC.cpsopt then cpsopt (function,NONE,false) | ||
107 : | else function | ||
108 : | monnier | 71 | val _ = prC "cpsopt" function |
109 : | monnier | 45 | |
110 : | monnier | 102 | val (function, dlit) = litsplit function |
111 : | val data = lit2cps dlit | ||
112 : | val _ = prC "cpsopt-code" function | ||
113 : | val _ = prC "cpsopt-data" data | ||
114 : | |||
115 : | monnier | 71 | fun gen fx = |
116 : | let val fx = (prC "closure" o closure) fx | ||
117 : | val carg = globalfix fx | ||
118 : | val carg = spill carg | ||
119 : | val (carg, limit) = limit carg | ||
120 : | in codegen (carg, limit, err); | ||
121 : | collect () | ||
122 : | end | ||
123 : | monnier | 102 | |
124 : | fun gdata dd = | ||
125 : | let val x = Control.CG.printit | ||
126 : | val y = !x | ||
127 : | val _ = (x := false) | ||
128 : | val fx = (prC "closure" o closureD) dd | ||
129 : | val carg = globalfixD fx | ||
130 : | val carg = spillD carg | ||
131 : | val (carg, limit) = limitD carg | ||
132 : | in codegenD (carg, limit, err); | ||
133 : | (collect ()) before (x := y) | ||
134 : | end | ||
135 : | monnier | 71 | in case CpsSplit.cpsSplit function |
136 : | monnier | 102 | of (fun0 :: funn) => (gen fun0, map gen funn, gdata data) |
137 : | monnier | 71 | | [] => bug "unexpected case on gen in flintcomp" |
138 : | end | ||
139 : | monnier | 102 | in {c0=nc0, cn=ncn, data=dseg, name=ref (SOME src)} |
140 : | monnier | 16 | end (* function flintcomp *) |
141 : | |||
142 : | monnier | 71 | val flintcomp = phase "Compiler 050 flintcomp" flintcomp |
143 : | monnier | 16 | |
144 : | end (* local *) | ||
145 : | end (* structure FLINTComp *) | ||
146 : | monnier | 95 | |
147 : | (* | ||
148 : | * $Log: flintcomp.sml,v $ | ||
149 : | * Revision 1.1.1.1 1998/04/08 18:39:40 george | ||
150 : | * Version 110.5 | ||
151 : | * | ||
152 : | *) |
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |