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/opt/fcontract.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml

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

revision 199, Wed Nov 25 18:30:38 1998 UTC revision 200, Sat Nov 28 17:48:03 1998 UTC
# Line 185  Line 185 
185      structure PP = PPFlint      structure PP = PPFlint
186      structure FU = FlintUtil      structure FU = FlintUtil
187      structure LT = LtyExtern      structure LT = LtyExtern
188        structure LK = LtyKernel
189      structure OU = OptUtils      structure OU = OptUtils
190      structure CTRL = Control.FLINT      structure CTRL = Control.FLINT
191  in  in
# Line 197  Line 198 
198  (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)  (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
199    
200  val cplv = LambdaVar.dupLvar  val cplv = LambdaVar.dupLvar
201    val mklv = LambdaVar.mkLvar
202    
203  datatype sval  datatype sval
204    = Val    of F.value                   (* F.value should never be F.VAR lv *)    = Val    of F.value                   (* F.value should never be F.VAR lv *)
# Line 220  Line 222 
222      LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)      LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
223    | tycs_eq _ = false    | tycs_eq _ = false
224    
225    (* calls `code' to append a lexp to each leaf of `le'.
226     * Typically used to transform `let lvs = le in code' so that
227     * `code' is now copied at the end of each branch of `le'.
228     * `lvs' is a list of lvars that should be used if the result of `le'
229     * needs to be bound before calling `code'. *)
230    fun append lvs code le =
231        let fun l (F.RET vs) = code vs
232              | l (le as (F.APP _ | F.TAPP _ | F.RAISE _ | F.HANDLE _)) =
233                let val lvs = map (fn lv => let val nlv = cplv lv
234                                            in C.new NONE nlv; nlv end)
235                                  lvs
236                in F.LET(lvs, le, code(map F.VAR lvs))
237                end
238              | l (F.LET (lvs,body,le)) = F.LET(lvs,body, l le)
239              | l (F.FIX (fdecs,le)) = F.FIX(fdecs, l le)
240              | l (F.TFN (tfdec,le)) = F.TFN(tfdec, l le)
241              | l (F.SWITCH (v,ac,arms,def)) =
242                let fun larm (con,le) = (con, l le)
243                in F.SWITCH(v, ac, map larm arms, O.map l def)
244                end
245              | l (F.CON (dc,tycs,v,lv,le)) = F.CON(dc, tycs, v, lv, l le)
246              | l (F.RECORD (rk,vs,lv,le)) = F.RECORD(rk, vs, lv, l le)
247              | l (F.SELECT (v,i,lv,le)) = F.SELECT(v, i, lv, l le)
248              | l (F.BRANCH (po,vs,le1,le2)) = F.BRANCH(po, vs, l le1, l le2)
249              | l (F.PRIMOP (po,vs,lv,le)) = F.PRIMOP(po, vs, lv, l le)
250        in l le
251        end
252    
253  fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)  fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)
254    
255  (*  val c_inline         = Stats.newCounter[] *)  (*  val c_inline         = Stats.newCounter[] *)
# Line 374  Line 404 
404       of F.RET vs => cont(m, F.RET(map substval vs))       of F.RET vs => cont(m, F.RET(map substval vs))
405    
406        | F.LET (lvs,le,body) =>        | F.LET (lvs,le,body) =>
407          let fun clet () =          let fun k (nm,nle) =
408                  loop m le                  let fun cbody () =
                      (fn (m,F.RET vs) =>  
                       let fun simplesubst (lv,v,m) =  
                               let val sv = val2sval m v  
                               in substitute(m, lv, sv, sval2val sv)  
                               end  
                           val nm = (ListPair.foldl simplesubst m (lvs, vs))  
                       in loop nm body cont  
                       end  
                        | (m,nle) =>  
409                           let val nm = (foldl (fn (lv,m) =>                           let val nm = (foldl (fn (lv,m) =>
410                                                addbind(m, lv, Var(lv, NONE)))                                                addbind(m, lv, Var(lv, NONE)))
411                                               m lvs)                                              nm lvs)
412                           in case loop nm body cont                           in case loop nm body cont
413                               of F.RET vs => if vs = (map F.VAR lvs) then nle                               of F.RET vs => if vs = (map F.VAR lvs) then nle
414                                              else F.LET(lvs, nle, F.RET vs)                                              else F.LET(lvs, nle, F.RET vs)
415                                | nbody => F.LET(lvs, nle, nbody)                                | nbody => F.LET(lvs, nle, nbody)
416                           end)                          end
417          in (* case le                  in case nle
418              of F.BRANCH (po,vs,le1,le2) =>                      of F.RET vs =>
419                           let fun simplesubst (lv,v,m) =
420                                   let val sv = val2sval m v
421                                   in substitute(m, lv, sv, sval2val sv)
422                                   end
423                               val nm = (ListPair.foldl simplesubst nm (lvs, vs))
424                           in loop nm body cont
425                           end
426                         | _ => cbody()
427                    end
428                fun clet () = loop m le k
429            in case le
430                of (F.BRANCH _ | F.SWITCH _) =>
431                 (* this is a hack originally meant to cleanup the BRANCH mess                 (* this is a hack originally meant to cleanup the BRANCH mess
432                  * introduced in flintnm (where each branch returns just true or                  * introduced in flintnm (where each branch returns just true or
433                  * false which is generally only used as input to a SWITCH).                  * false which is generally only used as input to a SWITCH).
434                  * The present code does slightly more than clean up this case *)                  * The present code does slightly more than clean up this case *)
435                 let fun known (F.RECORD(_,_,_,le)) = known le                 (* As it stands, the code has at least 2 serious shortcomings:
436                       | known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')                  * 1 - it applies to the code before fcontraction
437                       | known (F.RET[F.VAR v]) = false                  * 2 - the SWITCH copied into each arm doesn't get reduced
438                       | known (F.RET[_]) = true                  *     early, so the inlining that should happen cannot
439                       | known _ = false                  *     take place because by the time we know that the function
440                     fun cassoc (lv,v,body,wrap) =                  *     is a simple-inline candidate, fcontract already processed
441                         if lv = v andalso ((C.usenb(C.get lv)) handle x=> raise x) = 1 andalso                  *     the call *)
442                             known le1 andalso known le2 then  
443                             (* here I should also check that le1 != le2 *)                 (* `extract' extracts the code of a switch arm into a function
444                             let val nle1 = F.LET([lv], le1, body)                  * and replaces it with a call to that function *)
445                                 val nlv = cplv lv                 let fun extract (con,le) =
446                                 val _ = C.new NONE nlv                         let val f = mklv()
447                                 val body2 = C.copylexp (M.add(M.empty, lv, nlv))                             val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,
448                                                        body                                  cconv=F.CC_FUN(LK.FF_FIXED)}
449                                 val nle2 = F.LET([nlv], le2, body2)                         in case con of
450                             in                             F.DATAcon(dc as (_,_,lty),tycs,lv) =>
451                                 click_branch();                             let val nlv = cplv lv
452                                 loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont                                 val _ = C.new (SOME[lv]) f
453                                   val _ = C.use NONE (C.new NONE nlv)
454                                   val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))
455                               in ((F.DATAcon(dc, tycs, nlv),
456                                    F.APP(F.VAR f, [F.VAR nlv])),
457                                   (fk, f, [(lv, lty)], le))
458                               end
459                             | con =>
460                               let val _ = C.new (SOME[]) f
461                               in ((con, F.APP(F.VAR f, [])),
462                                   (fk, f, [], le))
463                               end
464                           end
465                       fun cassoc (lv,F.SWITCH(F.VAR v,ac,arms,NONE),wrap) =
466                           if lv <> v orelse C.usenb(C.get lv) > 1 then clet() else
467                               let val (narms,fdecs) =
468                                       ListPair.unzip (map extract arms)
469                                   fun addswitch [v] =
470                                       C.copylexp IntmapF.empty
471                                                  (F.SWITCH(v,ac,narms,NONE))
472                                     | addswitch _ = bug "Wrong number of values"
473                                   (* replace each leaf `ret' with a copy
474                                    * of the switch *)
475                                   val nle = append [lv] addswitch le
476                                   (* decorate with the functions extracted out
477                                    * of the switch arms *)
478                                   val nle = foldl (fn (f,le) => F.FIX([f],le))
479                                                   (wrap nle) fdecs
480                                   (* Ugly hack to alleviate problem 2 mentioned
481                                    * above: we go through the code twice *)
482                                   val nle = loop m nle #2
483                               in  click_branch();
484                                   loop m nle cont
485                             end                             end
                        else  
                            clet()  
486                 in case (lvs,body)                 in case (lvs,body)
487                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
488                        cassoc(lv, v, le, fn x => x)                        cassoc(lv, le, fn x => x)
489                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
490                        cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))                        cassoc(lv, le, fn le => F.LET(lvs,le,rest))
491                      | _ => clet()                      | _ => clet()
492                 end                 end
493               | _ => *) clet()               | _ => clet()
494          end          end
495    
496        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>

Legend:
Removed from v.199  
changed lines
  Added in v.200

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