Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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