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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 84, Wed May 6 22:35:33 1998 UTC revision 220, Tue Mar 9 02:15:05 1999 UTC
# Line 6  Line 6 
6  struct  struct
7    
8  local structure CB = CompBasic  local structure CB = CompBasic
9        structure CGC = Control.CG  (*        structure CGC = Control.CG *)
10        structure MachSpec = Gen.MachSpec        structure MachSpec = Gen.MachSpec
11        structure Convert = Convert(MachSpec)        structure Convert = Convert(MachSpec)
12        structure CPStrans = CPStrans(MachSpec)        structure CPStrans = CPStrans(MachSpec)
13        structure CPSopt = CPSopt(MachSpec)        structure CPSopt = CPSopt(MachSpec)
14        structure NewClosure = NClosure(MachSpec)        structure Closure = Closure(MachSpec)
15        structure Spill = Spill(MachSpec)        structure Spill = Spill(MachSpec)
16        structure CpsSplit = CpsSplitFun (MachSpec)        structure CpsSplit = CpsSplitFun (MachSpec)
17          structure CTRL = FLINT_Control
18          structure PP = PPFlint
19          structure LT = LtyExtern
20          structure O  = Option
21          structure F  = FLINT
22  in  in
23    
24  val architecture = Gen.MachSpec.architecture  val architecture = Gen.MachSpec.architecture
25  fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s)  fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s)
26  val say = Control.Print.say  val say = Control_Print.say
27    
28    datatype flintkind = FK_WRAP | FK_REIFY | FK_DEBRUIJN | FK_NAMED | FK_CPS
29    
30  fun phase x = Stats.doPhase (Stats.makePhase x)  fun phase x = Stats.doPhase (Stats.makePhase x)
31    
32  val fcollect  = phase "Compiler 052 collect" (fn le => (Collect.collect le; le))  val deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names
33  (*  val fcontract = phase "Compiler 052 fcontract" FContract.contract *)  val names2deb = phase "Compiler 057 names2deb" TvarCvt.names2debIndex
34    
35  val lcontract = phase "Compiler 052 lcontract" LContract.lcontract  val lcontract = phase "Compiler 052 lcontract" LContract.lcontract
36    (*  val lcontract' = phase "Compiler 052 lcontract'" LContract.lcontract *)
37    val fcollect  = phase "Compiler 052a fcollect" Collect.collect
38    val fcontract = phase "Compiler 052b fcontract" FContract.contract
39    val fcontract = fcontract o fcollect
40    val loopify   = phase "Compiler 057 loopify" Loopify.loopify
41    val fixfix    = phase "Compiler 056 fixfix" FixFix.fixfix
42    
43    val split     = phase "Compiler 058 split" FSplit.split
44    
45    val typelift  = phase "Compiler 0535 typelift" Lift.typeLift
46    val wformed   = phase "Compiler 0536 wformed" Lift.wellFormed
47    
48  val specialize= phase "Compiler 053 specialize" Specialize.specialize  val specialize= phase "Compiler 053 specialize" Specialize.specialize
49  val wrapping  = phase "Compiler 054 wrapping" Wrapping.wrapping  val wrapping  = phase "Compiler 054 wrapping" Wrapping.wrapping
50  val reify     = phase "Compiler 055 reify" Reify.reify  val reify     = phase "Compiler 055 reify" Reify.reify
51  (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *)  val recover   = phase "Compiler 05a recover" Recover.recover
52    
53  val convert   = phase "Compiler 060 convert" Convert.convert  val convert   = phase "Compiler 060 convert" Convert.convert
54  val cpstrans  = phase "Compiler 065 cpstrans" CPStrans.cpstrans  val cpstrans  = phase "Compiler 065 cpstrans" CPStrans.cpstrans
55  val cpsopt    = phase "Compiler 070 cpsopt" CPSopt.reduce  val cpsopt    = phase "Compiler 070 cpsopt" CPSopt.reduce
56  val closure   = phase "Compiler 080 closure"  NewClosure.closeCPS  val litsplit  = phase "Compiler 075 litsplit" Literals.litsplit
57    val lit2cps   = phase "Compiler 076 lit2cps" Literals.lit2cps
58    val closure   = phase "Compiler 080 closure"  Closure.closeCPS
59  val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix  val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix
60  val spill     = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize  val spill     = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize
61                  then phase "Compiler 100 spill" Spill.spill                  then phase "Compiler 100 spill" Spill.spill
# Line 41  Line 63 
63  val limit     = phase "Compiler 110 limit" Limit.nolimit  val limit     = phase "Compiler 110 limit" Limit.nolimit
64  val codegen   = phase "Compiler 120 cpsgen" Gen.codegen  val codegen   = phase "Compiler 120 cpsgen" Gen.codegen
65    
66    val closureD  = phase "Compiler 081 closureD"  Closure.closeCPS
67    val globalfixD= phase "Compiler 091 globalfixD" GlobalFix.globalfix
68    val spillD    = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize
69                    then phase "Compiler 101 spillD" Spill.spill
70                    else fn x => x
71    val limitD    = phase "Compiler 110 limitD" Limit.nolimit
72    val codegenD  = phase "Compiler 121 cpsgenD" Gen.codegen
73    
74  (** pretty printing for the FLINT and CPS code *)  (** pretty printing for the FLINT and CPS code *)
75  val (prF, prC) =  val (prF, prC) =
76    let fun prGen (flag,printE) s e =    let fun prGen (flag,printE) s e =
77          if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e; e)          if !flag then (say ("\n[After " ^ s ^ " ...]\n\n"); printE e;
78                           say "\n"; e)
79          else e          else e
80     in (prGen (CGC.printFlint, PPFlint.printProg),     in (prGen (CTRL.print, PPFlint.printProg),
81         prGen (CGC.printit, PPCps.printcps0))         prGen (Control.CG.printit, PPCps.printcps0))
82    end    end
83    
84  (** writing out a term into a error output file *)  (** writing out a term into a error output file *)
# Line 63  Line 93 
93        done ()        done ()
94    end (* function dumpTerm *)    end (* function dumpTerm *)
95    
96    val fcs : (FLINT.prog -> FLINT.prog) list ref = ref []
97    
98  (** compiling FLINT code into the binary machine code *)  (** compiling FLINT code into the binary machine code *)
99  fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =  fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =
100    let fun err severity s =    let fun err severity s =
101          error (0,0) severity (concat["Real constant out of range: ",s,"\n"])          error (0,0) severity (concat["Real constant out of range: ",s,"\n"])
102    
103        fun check (checkE,printE,chkId) (enableChk,lvl,logId) e =        fun check (checkE,printE,chkId) (lvl,logId) e =
104          (if !enableChk andalso checkE (e,lvl) then            if checkE (e,lvl) then
105             (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e);             (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e);
106              bug (chkId ^ " typing errors " ^ logId))              bug (chkId ^ " typing errors " ^ logId))
107              else ()
108          fun wff (f, s) = if wformed f then ()
109                           else print ("\nAfter " ^ s ^ " CODE NOT WELL FORMED\n")
110    
111          (* f:prog         flint code
112           * fi:prog opt    inlinable approximation of f
113           * fk:flintkind   what kind of flint variant this is
114           * l:string       last phase through which it went *)
115          fun runphase (p,(f,fi,fk,l)) =
116              case (p,fk)
117               of (("fcontract" | "lcontract"), FK_DEBRUIJN) =>
118                  (say("\n!! "^p^" cannot be applied to the DeBruijn form !!\n");
119                   (f, fi, fk, l))
120    
121                | ("fcontract",_)           => (fcontract f,  fi, fk, p)
122                | ("lcontract",_)           => (lcontract f,  fi, fk, p)
123                | ("fixfix",   _)           => (fixfix f,     fi, fk, p)
124                | ("loopify",  _)           => (loopify f,    fi, fk, p)
125                | ("specialize",FK_NAMED)   => (specialize f, fi, fk, p)
126                | ("wrap",FK_NAMED)         => (wrapping f,   fi, FK_WRAP, p)
127                | ("reify",FK_WRAP)         => (reify f,      fi, FK_REIFY, p)
128                | ("deb2names",FK_DEBRUIJN) => (deb2names f,  fi, FK_NAMED, p)
129                | ("names2deb",FK_NAMED)    => (names2deb f,  fi, FK_DEBRUIJN, p)
130                | ("typelift", _)           =>
131                  let val f = typelift f
132                  in if !CTRL.check then wff(f, p) else (); (f, fi, fk, p) end
133                | ("split",    FK_NAMED)    =>
134                  let val (f,fi) = split f in (f, fi, fk, p) end
135    
136                (* pseudo FLINT phases *)
137                | ("pickle",   _)           =>
138                  (valOf(UnpickMod.unpickleFLINT(PickMod.pickleFLINT(SOME f))),
139                   UnpickMod.unpickleFLINT(PickMod.pickleFLINT fi),
140                   fk, p)
141                | ("collect",_) => (fcollect f, fi, fk, p)
142                | _ =>
143                  ((case (p,fk)
144                     of ("id",_) => ()
145                      | ("wellformed",_) => wff(f,l)
146                      | ("recover",_) =>
147                        let val {getLty,...} = recover(f, fk = FK_REIFY)
148                        in CTRL.recover := (say o LT.lt_print o getLty o F.VAR)
149                        end
150                      | ("print",_) =>
151                        (say("\n[After "^l^"...]\n\n"); PP.printFundec f; say "\n")
152                      | ("printsplit", _) =>
153                        (say "[ splitted ]\n\n"; O.map PP.printFundec fi; say "\n")
154                      | ("check",_) =>
155                        (check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")
156                               (fk = FK_REIFY, l) f)
157                      | _ =>
158                        say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n"));
159                        (f, fi, fk, l))
160    
161          fun print (f,fi,fk,l) = (prF l f; (f, fi, fk, l))
162          fun check' (f,fi,fk,l) =
163              let fun c n reified f =
164                      check (ChkFlint.checkTop, PPFlint.printFundec, n)
165                            (reified, l) (names2deb f)
166              in if !CTRL.check then
167                  (c "FLINT" (fk = FK_REIFY) f; O.map (c "iFLINT" false) fi; ())
168           else ();           else ();
169           e)                   (f, fi, fk, l)
       fun chkF (b, s) =  
         check (ChkFlint.checkTop, PPFlint.printFundec,  
                "FLINT") (CGC.checkFlint, b, s)  
   
       val _ = (chkF (false,"1") o prF "Translation") flint  
       val flint = (chkF (false,"2") o prF "Lcontract" o lcontract) flint  
       val flint =  
         if !CGC.specialize then  
            (chkF (false,"3") o prF "Specialization" o specialize) flint  
         else flint  
   
       val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint  
       val flint = (chkF (true, "5") o prF "Reify" o reify) flint  
       val function = convert flint  
       val (nc0, ncn) =  
         let val _ = prC "convert" function  
             val function = (prC "cpstrans" o cpstrans) function  
             local exception ZZZ  
             in  
             val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ)  
170              end              end
171              val (function,table) =  
172                if !CGC.cpsopt then cpsopt (function,table,NONE,false)        fun runphase' (arg as (p,{1=f,...})) =
173                else (function,table)            (if !CTRL.printPhases then say("Phase "^p^"...") else ();
174               ((check' o print o runphase) arg) before
175               (if !CTRL.printPhases then say("..."^p^" Done.\n") else ()))
176                  handle x => (say ("\nwhile in "^p^" phase\n");
177                               dumpTerm(PPFlint.printFundec,"FLINT.core", f);
178                               raise x)
179    
180          val (flint,fi,fk,_) = foldl runphase'
181                                      (flint, NONE, FK_DEBRUIJN, "flintnm")
182                                      ((* "id" :: *) "deb2names" :: !CTRL.phases)
183    
184          (* run any missing phases *)
185          val (flint,fk) =
186              if fk = FK_DEBRUIJN
187              then (say "\n!!Forgot deb2names!!\n"; (deb2names flint, FK_NAMED))
188              else (flint,fk)
189          val (flint,fk) =
190              if fk = FK_NAMED
191              then (say "\n!!Forgot wrap!!\n"; (wrapping flint, FK_WRAP))
192              else (flint,fk)
193          val (flint,fk) =
194              if fk = FK_WRAP
195              then (say "\n!!Forgot reify!!\n"; (reify flint, FK_REIFY))
196              else (flint,fk)
197    
198          (* finish up with CPS *)
199          val (nc0, ncn, dseg) =
200            let val function = convert flint
201                val _ = prC "convert" function
202                val function = (prC "cpstrans" o cpstrans) function
203                val function = cpsopt (function,NONE,false)
204              val _ = prC "cpsopt" function              val _ = prC "cpsopt" function
205    
206                val (function, dlit) = litsplit function
207                val data = lit2cps dlit
208                val _ = prC "cpsopt-code" function
209                val _ = prC "cpsopt-data" data
210    
211              fun gen fx =              fun gen fx =
212                let val fx = (prC "closure" o closure) fx                let val fx = (prC "closure" o closure) fx
213                    val carg = globalfix fx                    val carg = globalfix fx
# Line 108  Line 216 
216                 in codegen (carg, limit, err);                 in codegen (carg, limit, err);
217                    collect ()                    collect ()
218                end                end
219    
220                fun gdata dd =
221                  let val x = Control.CG.printit
222                      val y = !x
223                      val _ = (x := false)
224                      val fx = (prC "closure" o closureD) dd
225                      val carg = globalfixD fx
226                      val carg = spillD carg
227                      val (carg, limit) = limitD carg
228                   in codegenD (carg, limit, err);
229                      (collect ()) before (x := y)
230                  end
231           in case CpsSplit.cpsSplit function           in case CpsSplit.cpsSplit function
232               of (fun0 :: funn) => (gen fun0, map gen funn)               of (fun0 :: funn) => (gen fun0, map gen funn, gdata data)
233                | [] => bug "unexpected case on gen in flintcomp"                | [] => bug "unexpected case on gen in flintcomp"
234          end          end
235     in {c0=nc0, cn=ncn , name=ref (SOME src)}     in ({c0=nc0, cn=ncn, data=dseg, name=ref (SOME src)}, fi)
236    end (* function flintcomp *)    end (* function flintcomp *)
237    
238  val flintcomp = phase "Compiler 050 flintcomp" flintcomp  val flintcomp = phase "Compiler 050 flintcomp" flintcomp
239    
240  end (* local *)  end (* local *)
241  end (* structure FLINTComp *)  end (* structure FLINTComp *)
242    
243    (*
244     * $Log$
245     *)

Legend:
Removed from v.84  
changed lines
  Added in v.220

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