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 198, Sun Nov 22 02:11:29 1998 UTC revision 220, Tue Mar 9 02:15:05 1999 UTC
# Line 14  Line 14 
14        structure Closure = Closure(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 = Control.FLINT        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  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 deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names
33    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  val fcollect  = phase "Compiler 052a fcollect" Collect.collect
38  val fcontract = phase "Compiler 052b fcontract" FContract.contract  val fcontract = phase "Compiler 052b fcontract" FContract.contract
39  val fcontract = fn f => (fcontract(fcollect f, Stats.newCounter[]))  val fcontract = fcontract o fcollect
40  val loopify   = phase "Compiler 057 loopify" Loopify.loopify  val loopify   = phase "Compiler 057 loopify" Loopify.loopify
41  val fixfix    = phase "Compiler 056 fixfix" FixFix.fixfix  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  val typelift  = phase "Compiler 0535 typelift" Lift.typeLift
46  val wformed   = phase "Compiler 0536 wformed" Lift.wellFormed  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 recover   = phase "Compiler 05a recover" Recover.recover
 val deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names  
 val names2deb = phase "Compiler 057 names2deb" TvarCvt.names2debIndex  
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
# Line 92  Line 100 
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 ();            else ()
          e)  
       fun chkF (b, s) =  
         check (ChkFlint.checkTop, PPFlint.printFundec,  
                "FLINT") (CTRL.check, b, s)  
   
108        fun wff (f, s) = if wformed f then ()        fun wff (f, s) = if wformed f then ()
109                         else print ("\nAfter " ^ s ^ " CODE NOT WELL FORMED\n")                         else print ("\nAfter " ^ s ^ " CODE NOT WELL FORMED\n")
110    
111        (* val fcing = ref (!fcs)        (* f:prog         flint code
112        fun fcontract f =         * fi:prog opt    inlinable approximation of f
113            case !fcing         * fk:flintkind   what kind of flint variant this is
            of fcontract::fcs => (fcing := fcs; fcontract f)  
             | [] => let val fcc = Stats.newCounter[]  
                         val fcname = "FContract-"^(Int.toString(length(!fcs)))  
                         val coname = "FCollect-"^(Int.toString(length(!fcs)))  
                         val lcname = "LContract-"^(Int.toString(length(!fcs)))  
                         val fcstat = Stats.newStat(fcname, [fcc])  
                         val fcphase = phase ("Compiler 052b "^fcname)  
                                             FContract.contract  
                         val cophase = phase ("Compiler 052a "^coname)  
                                             Collect.collect  
                         val lcphase = phase ("Compiler 052 "^lcname)  
                                             LContract.lcontract  
                         fun g c = (lcphase c; fcphase(cophase c,fcc))  
               in  
                   Stats.registerStat fcstat;  
                   fcs := (!fcs) @ [g];  
                   g f  
               end *)  
   
       (* f:FLINT.prog   flint codee  
        * r:boot         whether it has gone through reify yet  
114         * l:string       last phase through which it went *)         * l:string       last phase through which it went *)
115        fun runphase (p,(f,fk,l)) =        fun runphase (p,(f,fi,fk,l)) =
116            case (p,fk)            case (p,fk)
117             of (("fcontract" | "lcontract"), FK_DEBRUIJN) =>             of (("fcontract" | "lcontract"), FK_DEBRUIJN) =>
118                (say("\n!! "^p^" cannot be applied to the DeBruijn form !!\n");                (say("\n!! "^p^" cannot be applied to the DeBruijn form !!\n");
119                 (f, fk, l))                 (f, fi, fk, l))
120    
121              | ("fcontract",_)           => (fcontract f,  fk, p)              | ("fcontract",_)           => (fcontract f,  fi, fk, p)
122              | ("lcontract",_)           => (lcontract f,  fk, p)              | ("lcontract",_)           => (lcontract f,  fi, fk, p)
123              | ("fixfix",   _)           => (fixfix f,     fk, p)              | ("fixfix",   _)           => (fixfix f,     fi, fk, p)
124              | ("loopify",  _)           => (loopify f,    fk, p)              | ("loopify",  _)           => (loopify f,    fi, fk, p)
125              | ("specialize",FK_NAMED)   => (specialize f, fk, p)              | ("specialize",FK_NAMED)   => (specialize f, fi, fk, p)
126              | ("wrap",FK_NAMED)         => (wrapping f,   FK_WRAP, p)              | ("wrap",FK_NAMED)         => (wrapping f,   fi, FK_WRAP, p)
127              | ("reify",FK_WRAP)         => (reify f,      FK_REIFY, p)              | ("reify",FK_WRAP)         => (reify f,      fi, FK_REIFY, p)
128              | ("deb2names",FK_DEBRUIJN) => (deb2names f,  FK_NAMED, p)              | ("deb2names",FK_DEBRUIJN) => (deb2names f,  fi, FK_NAMED, p)
129              | ("names2deb",FK_NAMED)    => (names2deb f,  FK_DEBRUIJN, p)              | ("names2deb",FK_NAMED)    => (names2deb f,  fi, FK_DEBRUIJN, p)
130              | ("typelift", _)           =>              | ("typelift", _)           =>
131                let val f' = typelift f                let val f = typelift f
132                in if !CTRL.check then wff(f', p) else (); (f', fk, p) end                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 *)              (* pseudo FLINT phases *)
137              | ("id",_) => (f,fk,l)              | ("pickle",   _)           =>
138              | ("collect",_) => (fcollect f, fk, p)                (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",_) =>              | ("print",_) =>
151                (say("\n\n[ After "^l^"... ]\n\n");                      (say("\n[After "^l^"...]\n\n"); PP.printFundec f; say "\n")
152                 PPFlint.printFundec f;                    | ("printsplit", _) =>
153                 (f, fk, l) before say "\n")                      (say "[ splitted ]\n\n"; O.map PP.printFundec fi; say "\n")
             | ("wellformed",_) => (wff(f,l); (f,fk,p))  
154              | ("check",_) =>              | ("check",_) =>
155                (check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")                (check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")
156                       (ref true, fk = FK_REIFY, l) f; (f,fk,l))                             (fk = FK_REIFY, l) f)
157              | _ =>              | _ =>
158                (say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n");                      say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n"));
159                 (f,fk,l))                      (f, fi, fk, l))
160    
161        fun print (f,fk,l) = (prF l f; (f, fk, l))        fun print (f,fi,fk,l) = (prF l f; (f, fi, fk, l))
162        fun check (f,fk,l) =        fun check' (f,fi,fk,l) =
163            ((* if fk <> FK_NAMED *) chkF (fk = FK_REIFY, l) (names2deb f) (* else f *);            let fun c n reified f =
164             (f, fk, l))                    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 ();
169                     (f, fi, fk, l)
170              end
171    
172        fun runphase' (arg as (p,{1=f,...})) =        fun runphase' (arg as (p,{1=f,...})) =
173            (if !CTRL.printPhases then say("Phase "^p^"...") else ();            (if !CTRL.printPhases then say("Phase "^p^"...") else ();
174             ((check o print o runphase) arg) before             ((check' o print o runphase) arg) before
175             (if !CTRL.printPhases then say("..."^p^" Done.\n") else ()))             (if !CTRL.printPhases then say("..."^p^" Done.\n") else ()))
176                handle x => (say ("\nwhile in "^p^" phase\n");                handle x => (say ("\nwhile in "^p^" phase\n");
177                             dumpTerm(PPFlint.printFundec,"FLINT.core", f);                             dumpTerm(PPFlint.printFundec,"FLINT.core", f);
178                             raise x)                             raise x)
179    
180        (* the "id" phase is just added to do the print/check at the entrance *)        val (flint,fi,fk,_) = foldl runphase'
181        val (flint,fk,_) = foldl runphase'                                    (flint, NONE, FK_DEBRUIJN, "flintnm")
182                                 (deb2names flint, FK_NAMED, "flintnm")                                    ((* "id" :: *) "deb2names" :: !CTRL.phases)
                                ((*  "id" :: *) !CTRL.phases)  
183    
184        (* run any missing phases *)        (* run any missing phases *)
185        val (flint,fk) =        val (flint,fk) =
# Line 233  Line 232 
232               of (fun0 :: funn) => (gen fun0, map gen funn, gdata data)               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, data=dseg, 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

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

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