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 64, Tue Mar 31 05:26:51 1998 UTC revision 251, Mon Apr 19 02:55:26 1999 UTC
# Line 1  Line 1 
1  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2  (* flintcomp.sml *)  (* flintcomp.sml *)
3    
4  functor FLINTComp (structure Gen: CPSGEN  functor FLINTComp (structure Gen: MACHINE_GEN
5                     val collect: unit -> Word8Vector.vector) : CODEGENERATOR =                     val collect: unit -> CodeObj.code_object) : CODEGENERATOR =
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 = SpillFn(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    structure Machine = Gen
25  val architecture = Gen.MachSpec.architecture  val architecture = Gen.MachSpec.architecture
26  fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s)  fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s)
27  val say = Control.Print.say  val say = Control_Print.say
28    
29    datatype flintkind = FK_WRAP | FK_REIFY | FK_DEBRUIJN | FK_NAMED | FK_CPS
30    
31  fun phase x = Stats.doPhase (Stats.makePhase x)  fun phase x = Stats.doPhase (Stats.makePhase x)
32    
33  val collLexp  = phase "Compiler 052 collect" (fn le => (Collect.collect le; le))  val deb2names = phase "Compiler 056 deb2names" TvarCvt.debIndex2names
34  val fconLexp  = phase "Compiler 052 fcontract" FContract.contract  val names2deb = phase "Compiler 057 names2deb" TvarCvt.names2debIndex
35  val lconLexp  = phase "Compiler 052 lcontract" LContract.lcontract  
36  val specLexp  = phase "Compiler 053 specLexp" Specialize.specialize  val lcontract = phase "Compiler 052 lcontract" LContract.lcontract
37  val wrapLexp  = phase "Compiler 054 wrapLexp" Wrapping.wrapLexp  (*  val lcontract' = phase "Compiler 052 lcontract'" LContract.lcontract *)
38  val wrapLexpN = phase "Compiler 054 wrapLexpN" WrappingNEW.wrapping  val fcollect  = phase "Compiler 052a fcollect" Collect.collect
39  val ltyComp   = phase "Compiler 055 ltyComp" Reify.ltyComp  val fcontract = phase "Compiler 052b fcontract" FContract.contract
40  val reify     = phase "Compiler 055 ltyCompN" ReifyNEW.reify  val fcontract = fcontract o fcollect
41  val narrow    = phase "Compiler 056 ltNarrow" LtNarrow.narrow  val loopify   = phase "Compiler 057 loopify" Loopify.loopify
42  (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *)  val fixfix    = phase "Compiler 056 fixfix" FixFix.fixfix
43    
44    val split     = phase "Compiler 058 split" FSplit.split
45    
46    val typelift  = phase "Compiler 0535 typelift" Lift.typeLift
47    val wformed   = phase "Compiler 0536 wformed" Lift.wellFormed
48    
49    val specialize= phase "Compiler 053 specialize" Specialize.specialize
50    val wrapping  = phase "Compiler 054 wrapping" Wrapping.wrapping
51    val reify     = phase "Compiler 055 reify" Reify.reify
52    val recover   = phase "Compiler 05a recover" Recover.recover
53    
54  val convert   = phase "Compiler 060 Convert" Convert.convert  val convert   = phase "Compiler 060 convert" Convert.convert
55  val cpstrans  = phase "Compiler 065 CPStrans" CPStrans.cpstrans  val cpstrans  = phase "Compiler 065 cpstrans" CPStrans.cpstrans
56  val cpsopt    = phase "Compiler 070 cpsopt" CPSopt.reduce  val cpsopt    = phase "Compiler 070 cpsopt" CPSopt.reduce
57  val closure   = phase "Compiler 080 closure"  NewClosure.closeCPS  val litsplit  = phase "Compiler 075 litsplit" Literals.litsplit
58    val litToBytes = phase "Compiler 076 litToBytes" Literals.litToBytes
59    val closure   = phase "Compiler 080 closure"  Closure.closeCPS
60  val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix  val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix
61  val spill     = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize  val spill     = phase "Compiler 100 spill" Spill.spill
                 then phase "Compiler 100 spill" Spill.spill  
                 else fn x => x  
62  val limit     = phase "Compiler 110 limit" Limit.nolimit  val limit     = phase "Compiler 110 limit" Limit.nolimit
63  val codegen   = phase "Compiler 120 cpsgen" Gen.codegen  val codegen   = phase "Compiler 120 cpsgen" Gen.codegen
64    
65  fun prGen (flag,printE) s e =  (** pretty printing for the FLINT and CPS code *)
66    (if !flag then (say ("\n\n[ After " ^ s ^ " ... ]\n\n"); printE e) else ();  val (prF, prC) =
67     e)    let fun prGen (flag,printE) s e =
68            if !flag then (say ("\n[After " ^ s ^ " ...]\n\n"); printE e;
69  val prLexp  = prGen (CGC.printLambda, MCprint.printLexp)                         say "\n"; e)
70  val prFlint = prGen (CGC.printFlint, PPFlint.printProg)          else e
71  val prCps   = prGen (CGC.printit, PPCps.printcps0)     in (prGen (CTRL.print, PPFlint.printProg),
72           prGen (Control.CG.printit, PPCps.printcps0))
73  (** compiling FLINT code into the binary machine code *)    end
 fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =  
   let fun err severity s =  
         error (0,0) severity (concat["Real constant out of range: ",s,"\n"])  
74    
75    (** writing out a term into a error output file *)
76        fun dumpTerm (printE, s, le) =        fun dumpTerm (printE, s, le) =
77          let val outS = TextIO.openAppend (src ^ s);    let val outS = TextIO.openAppend s;
78              val saveOut = !Control.Print.out              val saveOut = !Control.Print.out
79              fun done () =              fun done () =
80                  (TextIO.closeOut outS; Control.Print.out := saveOut)                  (TextIO.closeOut outS; Control.Print.out := saveOut)
# Line 66  Line 82 
82                                    flush = fn () => TextIO.flushOut outS};                                    flush = fn () => TextIO.flushOut outS};
83              printE le handle x => (done () handle _ => (); raise x);              printE le handle x => (done () handle _ => (); raise x);
84              done ()              done ()
85          end    end (* function dumpTerm *)
   
       (* checking for type errors in various phases. *)  
       fun check (checkE,printE,chkId) (enableChk,lvl,logId) e =  
         (if !enableChk andalso checkE (e,lvl) then  
            (dumpTerm (printE, "." ^ chkId ^ logId, e)  
             (* the following line will cause type errors to halt  
              * compilation.  i'd rather let it continue. --league  
              *)  
 (*          bug (chkId ^ " typing errors " ^ logId) *)  
             )  
          else ();  
          e)  
       val chkLexp = check (CheckLty.checkLty, MCprint.printLexp, "lambda")  
       val chkFlint = check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")  
   
       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  
   
       val flint =  
         if !CGC.specialize then  
            (chkFlint (CGC.checkFlint,1,"3")  
             o prFlint "Specialization" o specLexp) flint  
         else flint  
   
 (*  
       (*** explicit FLINT checking phase ***)  
       val flint = chkFlint (ref true, 3, "3") flint  
   
       (*** check out the new wrapping function *)  
       val nflint1 = (prFlint "NewWrapping" o wrapLexpN) flint  
       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  
86    
87        val lambda = (chkLexp (CGC.checklty1,21,"3") o ltyComp) lambda  val fcs : (FLINT.prog -> FLINT.prog) list ref = ref []
88    
89        val lambda =  (** compiling FLINT code into the binary machine code *)
90          (chkLexp (CGC.checklty1,21,"4") o prLexp "Narrowing" o narrow) lambda  fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) =
91      let fun err severity s =
92  (*          error (0,0) severity (concat["Real constant out of range: ",s,"\n"])
       val lambda = (chkLexp (CGC.checklty2,21,"5") o lambdaopt) lambda  
 *)  
93    
94        val (function,table) = convert lambda        fun check (checkE,printE,chkId) (lvl,logId) e =
95        local exception ZZZ            if checkE (e,lvl) then
96        in val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ)                (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e);
97                   bug (chkId ^ " typing errors " ^ logId))
98              else ()
99          fun wff (f, s) = if wformed f then ()
100                           else print ("\nAfter " ^ s ^ " CODE NOT WELL FORMED\n")
101    
102          (* f:prog         flint code
103           * fi:prog opt    inlinable approximation of f
104           * fk:flintkind   what kind of flint variant this is
105           * l:string       last phase through which it went *)
106          fun runphase (p,(f,fi,fk,l)) =
107              case (p,fk)
108               of (("fcontract" | "lcontract"), FK_DEBRUIJN) =>
109                  (say("\n!! "^p^" cannot be applied to the DeBruijn form !!\n");
110                   (f, fi, fk, l))
111    
112                | ("fcontract",_)           => (fcontract f,  fi, fk, p)
113                | ("lcontract",_)           => (lcontract f,  fi, fk, p)
114                | ("fixfix",   _)           => (fixfix f,     fi, fk, p)
115                | ("loopify",  _)           => (loopify f,    fi, fk, p)
116                | ("specialize",FK_NAMED)   => (specialize f, fi, fk, p)
117                | ("wrap",FK_NAMED)         => (wrapping f,   fi, FK_WRAP, p)
118                | ("reify",FK_WRAP)         => (reify f,      fi, FK_REIFY, p)
119                | ("deb2names",FK_DEBRUIJN) => (deb2names f,  fi, FK_NAMED, p)
120                | ("names2deb",FK_NAMED)    => (names2deb f,  fi, FK_DEBRUIJN, p)
121                | ("typelift", _)           =>
122                  let val f = typelift f
123                  in if !CTRL.check then wff(f, p) else (); (f, fi, fk, p) end
124                | ("split",    FK_NAMED)    =>
125                  let val (f,fi) = split f in (f, fi, fk, p) end
126    
127                (* pseudo FLINT phases *)
128                | ("pickle",   _)           =>
129                  (valOf(UnpickMod.unpickleFLINT(PickMod.pickleFLINT(SOME f))),
130                   UnpickMod.unpickleFLINT(PickMod.pickleFLINT fi),
131                   fk, p)
132                | ("collect",_) => (fcollect f, fi, fk, p)
133                | _ =>
134                  ((case (p,fk)
135                     of ("id",_) => ()
136                      | ("wellformed",_) => wff(f,l)
137                      | ("recover",_) =>
138                        let val {getLty,...} = recover(f, fk = FK_REIFY)
139                        in CTRL.recover := (say o LT.lt_print o getLty o F.VAR)
140                        end
141                      | ("print",_) =>
142                        (say("\n[After "^l^"...]\n\n"); PP.printFundec f; say "\n")
143                      | ("printsplit", _) =>
144                        (say "[ splitted ]\n\n"; O.map PP.printFundec fi; say "\n")
145                      | ("check",_) =>
146                        (check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT")
147                               (fk = FK_REIFY, l) f)
148                      | _ =>
149                        say("\n!! Unknown or badly scheduled FLINT phase '"^p^"' !!\n"));
150                        (f, fi, fk, l))
151    
152          fun print (f,fi,fk,l) = (prF l f; (f, fi, fk, l))
153          fun check' (f,fi,fk,l) =
154              let fun c n reified f =
155                      check (ChkFlint.checkTop, PPFlint.printFundec, n)
156                            (reified, l) (names2deb f)
157              in if !CTRL.check then
158                  (c "FLINT" (fk = FK_REIFY) f; O.map (c "iFLINT" false) fi; ())
159                 else ();
160                     (f, fi, fk, l)
161        end        end
       val _ = prCps "convert" function  
   
       val function = (prCps "cpstrans" o cpstrans) function  
162    
163        val (function,table) =        fun runphase' (arg as (p,{1=f,...})) =
164          if !CGC.cpsopt then cpsopt (function,table,NONE,false)            (if !CTRL.printPhases then say("Phase "^p^"...") else ();
165          else (function,table)             ((check' o print o runphase) arg) before
166        val _ = prCps "cpsopt" function             (if !CTRL.printPhases then say("..."^p^" Done.\n") else ()))
167                  handle x => (say ("\nwhile in "^p^" phase\n");
168        fun gen function = let                             dumpTerm(PPFlint.printFundec,"FLINT.core", f);
169            val function = (prCps "closure" o closure) function                             raise x)
170            val carg = globalfix function  
171          val (flint,fi,fk,_) = foldl runphase'
172                                      (flint, NONE, FK_DEBRUIJN, "flintnm")
173                                      ((* "id" :: *) "deb2names" :: !CTRL.phases)
174    
175          (* run any missing phases *)
176          val (flint,fk) =
177              if fk = FK_DEBRUIJN
178              then (say "\n!!Forgot deb2names!!\n"; (deb2names flint, FK_NAMED))
179              else (flint,fk)
180          val (flint,fk) =
181              if fk = FK_NAMED
182              then (say "\n!!Forgot wrap!!\n"; (wrapping flint, FK_WRAP))
183              else (flint,fk)
184          val (flint,fk) =
185              if fk = FK_WRAP
186              then (say "\n!!Forgot reify!!\n"; (reify flint, FK_REIFY))
187              else (flint,fk)
188    
189          (* finish up with CPS *)
190          val (nc0, ncn, dseg) =
191            let val function = convert flint
192                val _ = prC "convert" function
193                val function = (prC "cpstrans" o cpstrans) function
194                val function = cpsopt (function,NONE,false)
195                val _ = prC "cpsopt" function
196    
197                val (function, dlit) = litsplit function
198                val data = litToBytes dlit
199                val _ = prC "cpsopt-code" function
200    
201    (** NOTE: we should be passing the source-code name (src) to the
202     ** code generator somehow (for the second argument to code object allocation).
203     **)
204                fun gen fx =
205                  let val fx = (prC "closure" o closure) fx
206                      val carg = globalfix fx
207            val carg = spill carg            val carg = spill carg
208            val (carg, limit) = limit carg            val (carg, limit) = limit carg
209        in                 in codegen (carg, limit, err);
           codegen (carg, limit, err);  
210            collect ()            collect ()
211        end        end
212    
213        val fun0 :: funn = CpsSplit.cpsSplit function           in case CpsSplit.cpsSplit function
214        val c0 = gen fun0               of (fun0 :: funn) => (gen fun0, map gen funn, data)
215        val cn = map gen funn                | [] => bug "unexpected case on gen in flintcomp"
216            end
217     in {c0=c0, cn=cn , name=ref (SOME src)}     in ({c0=nc0, cn=ncn, data=dseg}, fi)
218    end (* function flintcomp *)    end (* function flintcomp *)
219    
220  val flintcomp = phase "Compiler 050 FLINTComp" flintcomp  val flintcomp = phase "Compiler 050 flintcomp" flintcomp
221    
222  end (* local *)  end (* local *)
223  end (* structure FLINTComp *)  end (* structure FLINTComp *)
224    
225    (*
226     * $Log: flintcomp.sml,v $
227     * Revision 1.8  1999/01/11 16:53:25  george
228     *   new array representation support
229     *
230     *)

Legend:
Removed from v.64  
changed lines
  Added in v.251

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