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
[smlnj] / 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 64, Tue Mar 31 05:26:51 1998 UTC revision 71, Fri Apr 3 01:57:57 1998 UTC
# Line 22  Line 22 
22    
23  fun phase x = Stats.doPhase (Stats.makePhase x)  fun phase x = Stats.doPhase (Stats.makePhase x)
24    
25  val collLexp  = phase "Compiler 052 collect" (fn le => (Collect.collect le; le))  val fcollect  = phase "Compiler 052 collect" (fn le => (Collect.collect le; le))
26  val fconLexp  = phase "Compiler 052 fcontract" FContract.contract  val fcontract = phase "Compiler 052 fcontract" FContract.contract
27  val lconLexp  = phase "Compiler 052 lcontract" LContract.lcontract  val lcontract = phase "Compiler 052 lcontract" LContract.lcontract
28  val specLexp  = phase "Compiler 053 specLexp" Specialize.specialize  val specialize= phase "Compiler 053 specialize" Specialize.specialize
29  val wrapLexp  = phase "Compiler 054 wrapLexp" Wrapping.wrapLexp  val wrapping  = phase "Compiler 054 wrapping" Wrapping.wrapping
30  val wrapLexpN = phase "Compiler 054 wrapLexpN" WrappingNEW.wrapping  val reify     = phase "Compiler 055 reify" Reify.reify
 val ltyComp   = phase "Compiler 055 ltyComp" Reify.ltyComp  
 val reify     = phase "Compiler 055 ltyCompN" ReifyNEW.reify  
 val narrow    = phase "Compiler 056 ltNarrow" LtNarrow.narrow  
31  (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *)  (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *)
32    
33  val convert   = phase "Compiler 060 Convert" Convert.convert  val convert   = phase "Compiler 060 convert" Convert.convert
34  val cpstrans  = phase "Compiler 065 CPStrans" CPStrans.cpstrans  val cpstrans  = phase "Compiler 065 cpstrans" CPStrans.cpstrans
35  val cpsopt    = phase "Compiler 070 cpsopt" CPSopt.reduce  val cpsopt    = phase "Compiler 070 cpsopt" CPSopt.reduce
36  val closure   = phase "Compiler 080 closure"  NewClosure.closeCPS  val closure   = phase "Compiler 080 closure"  NewClosure.closeCPS
37  val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix  val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix
# Line 44  Line 41 
41  val limit     = phase "Compiler 110 limit" Limit.nolimit  val limit     = phase "Compiler 110 limit" Limit.nolimit
42  val codegen   = phase "Compiler 120 cpsgen" Gen.codegen  val codegen   = phase "Compiler 120 cpsgen" Gen.codegen
43    
 fun prGen (flag,printE) s e =  
   (if !flag then (say ("\n\n[ After " ^ s ^ " ... ]\n\n"); printE e) else ();  
    e)  
   
 val prLexp  = prGen (CGC.printLambda, MCprint.printLexp)  
 val prFlint = prGen (CGC.printFlint, PPFlint.printProg)  
 val prCps   = prGen (CGC.printit, PPCps.printcps0)  
44    
45  (** compiling FLINT code into the binary machine code *)  (** pretty printing for the FLINT and CPS code *)
46  fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =  val (prF, prC) =
47    let fun err severity s =    let fun prGen (flag,printE) s e =
48          error (0,0) severity (concat["Real constant out of range: ",s,"\n"])          if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e; e)
49            else e
50       in (prGen (CGC.printFlint, PPFlint.printProg),
51           prGen (CGC.printit, PPCps.printcps0))
52      end
53    
54    (** writing out a term into a error output file *)
55        fun dumpTerm (printE, s, le) =        fun dumpTerm (printE, s, le) =
56          let val outS = TextIO.openAppend (src ^ s);    let val outS = TextIO.openAppend s;
57              val saveOut = !Control.Print.out              val saveOut = !Control.Print.out
58              fun done () =              fun done () =
59                  (TextIO.closeOut outS; Control.Print.out := saveOut)                  (TextIO.closeOut outS; Control.Print.out := saveOut)
# Line 66  Line 61 
61                                    flush = fn () => TextIO.flushOut outS};                                    flush = fn () => TextIO.flushOut outS};
62              printE le handle x => (done () handle _ => (); raise x);              printE le handle x => (done () handle _ => (); raise x);
63              done ()              done ()
64          end    end (* function dumpTerm *)
65    
66    (** compiling FLINT code into the binary machine code *)
67    fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =
68      let fun err severity s =
69            error (0,0) severity (concat["Real constant out of range: ",s,"\n"])
70    
       (* checking for type errors in various phases. *)  
71        fun check (checkE,printE,chkId) (enableChk,lvl,logId) e =        fun check (checkE,printE,chkId) (enableChk,lvl,logId) e =
72          (if !enableChk andalso checkE (e,lvl) then          (if !enableChk andalso checkE (e,lvl) then
73             (dumpTerm (printE, "." ^ chkId ^ logId, e)             (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e);
74              (* the following line will cause type errors to halt              bug (chkId ^ " typing errors " ^ logId))
              * compilation.  i'd rather let it continue. --league  
              *)  
 (*          bug (chkId ^ " typing errors " ^ logId) *)  
             )  
75           else ();           else ();
76           e)           e)
77        val chkLexp = check (CheckLty.checkLty, MCprint.printLexp, "lambda")        fun chkF (b, s) =
78        val chkFlint = check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")          check (ChkFlint.checkTop, PPFlint.printFundec,
79                   "FLINT") (CGC.checkFlint, b, s)
       val _ = (chkFlint (CGC.checkFlint,1,"1") o prFlint "Translation") flint  
   
       val _ = (PPFlint.LVarString := Collect.LVarString)  
       val _ = (prFlint "Collect" o collLexp) flint  
   
       val flint =  
         (chkFlint (CGC.checkFlint,1,"2") o prFlint "Fcontract" o fconLexp)  
         flint  
   
       val _ = (PPFlint.LVarString := LambdaVar.lvarName)  
   
       val flint =  
         (chkFlint (CGC.checkFlint,1,"2") o prFlint "Lcontract" o lconLexp)  
         flint  
80    
81          val _ = (chkF (false,"1") o prF "Translation") flint
82          val flint = (chkF (false,"2") o prF "Lcontract" o lcontract) flint
83        val flint =        val flint =
84          if !CGC.specialize then          if !CGC.specialize then
85             (chkFlint (CGC.checkFlint,1,"3")             (chkF (false,"3") o prF "Specialization" o specialize) flint
             o prFlint "Specialization" o specLexp) flint  
86          else flint          else flint
87    
88  (*        val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint
89        (*** explicit FLINT checking phase ***)        val flint = (chkF (true, "5") o prF "Reify" o reify) flint
90        val flint = chkFlint (ref true, 3, "3") flint        val function = convert flint
91          val (nc0, ncn) =
92        (*** check out the new wrapping function *)          let val _ = prC "convert" function
93        val nflint1 = (prFlint "NewWrapping" o wrapLexpN) flint              val function = (prC "cpstrans" o cpstrans) function
       val nflint2 = chkFlint (ref true, 4, "4") nflint1  
       val nflint3 =  
         (chkFlint (ref false, 5, "5") o prFlint "NewReify" o reify) nflint2  
       val nlambda = Flint2Lambda.transFundec(nflint3)  
       val nlambda =  
         (chkLexp (CGC.checklty1,21,"4") o prLexp "NarrowingN" o narrow) nlambda  
       val (nfunction,ntable) = convert nlambda  
 *)  
   
       val lambda =  
         (chkLexp (CGC.checklty1,1,"1")  
          o prLexp "Translation-To-Lambda"  
          o Flint2Lambda.transFundec)  
         flint  
   
       val lambda =  
         (chkLexp (CGC.checklty1,11,"2") o prLexp "Wrapping" o wrapLexp)  
         lambda  
   
       val lambda = (chkLexp (CGC.checklty1,21,"3") o ltyComp) lambda  
   
       val lambda =  
         (chkLexp (CGC.checklty1,21,"4") o prLexp "Narrowing" o narrow) lambda  
   
 (*  
       val lambda = (chkLexp (CGC.checklty2,21,"5") o lambdaopt) lambda  
 *)  
   
       val (function,table) = convert lambda  
94        local exception ZZZ        local exception ZZZ
95        in val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ)              in
96                val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ)
97        end        end
       val _ = prCps "convert" function  
   
       val function = (prCps "cpstrans" o cpstrans) function  
   
98        val (function,table) =        val (function,table) =
99          if !CGC.cpsopt then cpsopt (function,table,NONE,false)          if !CGC.cpsopt then cpsopt (function,table,NONE,false)
100          else (function,table)          else (function,table)
101        val _ = prCps "cpsopt" function              val _ = prC "cpsopt" function
102    
103        fun gen function = let              fun gen fx =
104            val function = (prCps "closure" o closure) function                let val fx = (prC "closure" o closure) fx
105            val carg = globalfix function                    val carg = globalfix fx
106            val carg = spill carg            val carg = spill carg
107            val (carg, limit) = limit carg            val (carg, limit) = limit carg
108        in                 in codegen (carg, limit, err);
           codegen (carg, limit, err);  
109            collect ()            collect ()
110        end        end
111             in case CpsSplit.cpsSplit function
112        val fun0 :: funn = CpsSplit.cpsSplit function               of (fun0 :: funn) => (gen fun0, map gen funn)
113        val c0 = gen fun0                | [] => bug "unexpected case on gen in flintcomp"
114        val cn = map gen funn          end
115       in {c0=nc0, cn=ncn , name=ref (SOME src)}
    in {c0=c0, cn=cn , name=ref (SOME src)}  
116    end (* function flintcomp *)    end (* function flintcomp *)
117    
118  val flintcomp = phase "Compiler 050 FLINTComp" flintcomp  val flintcomp = phase "Compiler 050 flintcomp" flintcomp
119    
120  end (* local *)  end (* local *)
121  end (* structure FLINTComp *)  end (* structure FLINTComp *)
Legend:
Removed from v.64  
changed lines
  Added in v.71
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge