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

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

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

revision 196, Fri Nov 20 18:16:19 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 37  Line 37 
37  datatype info  datatype info
38    = SimpVal of value    = SimpVal of value
39    | ListExp of value list    | ListExp of value list
40    | FunExp of DI.depth * lvar list * lexp    | FunExp of lvar list * lexp
41    | ConExp of dcon * tyc list * value    | ConExp of dcon * tyc list * value
42    | StdExp    | StdExp
43    
# Line 168  Line 168 
168  (** contracting a function application *)  (** contracting a function application *)
169  fun appInfo (VAR v) =  fun appInfo (VAR v) =
170        ((case get v        ((case get v
171           of (ref 0, FunExp (d, vs, e)) => SOME (d, vs, e)           of (ref 0, FunExp (vs, e)) => SOME (vs, e)
172            | _ => NONE) handle _ => NONE)            | _ => NONE) handle _ => NONE)
173    | appInfo _ = NONE    | appInfo _ = NONE
174    
# Line 224  Line 224 
224    
225    
226  (** the main transformation function *)  (** the main transformation function *)
 fun transform [] = bug "unexpected case in transform"  
   | transform (cfg as ((d, od, k)::rcfg)) = let  
      fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)  
        | h (f, t, [], _) = t  
      fun ltf t = h(LT.lt_adj_k, t, cfg, 0)  
      fun tcf t = h(LT.tc_adj_k, t, cfg, 0)  
227    
228       fun lpacc (DA.LVAR v) =       fun lpacc (DA.LVAR v) =
229             (case lpsv (VAR v) of VAR w => DA.LVAR w             (case lpsv (VAR v) of VAR w => DA.LVAR w
230                                 | _ => bug "unexpected in lpacc")                                 | _ => bug "unexpected in lpacc")
231         | lpacc _ = bug "unexpected path in lpacc"         | lpacc _ = bug "unexpected path in lpacc"
232    
233       and lpdc (s, DA.EXN acc, t) = (s, DA.EXN(lpacc acc), ltf t)       and lpdc (s, DA.EXN acc, t) = (s, DA.EXN(lpacc acc), t)
234         | lpdc (s, rep, t) = (s, rep, ltf t)         | lpdc (s, rep, t) = (s, rep, t)
235    
236       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, map tcf ts, v)       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, ts, v)
237         | lpcon c = c         | lpcon c = c
238    
239       and lpdt (SOME {default=v, table=ws}) =       and lpdt (SOME {default=v, table=ws}) =
# Line 252  Line 246 
246    
247       and lpsv x = (case x of VAR v => rename x | _ => x)       and lpsv x = (case x of VAR v => rename x | _ => x)
248    
249       and lpfd (fk, v, vts, e) =       and lpfd ({isrec, known, inline, cconv}, v, vts, e) =
250         let val nfk =           (* The function body might have changed so we need to reset
251               case fk            * the inlining hint *)
252                of {isrec=SOME(t,lk), known, inline, cconv} =>           ({isrec=isrec, known=known, inline=IH_SAFE, cconv=cconv},
253                     {isrec=SOME(map ltf t, lk), known=known, inline=IH_SAFE,            v, vts, #1(loop e))
                            cconv=cconv}  
                | _ => fk  
         in (nfk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))  
        end  
254    
255       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
256         let val _ = chkIn(v, info)         let val _ = chkIn(v, info)
# Line 314  Line 304 
304                let fun g ({isrec=SOME _, ...} :fkind, v, _, _) =                let fun g ({isrec=SOME _, ...} :fkind, v, _, _) =
305                           chkIn(v, StdExp)                           chkIn(v, StdExp)
306                      | g ((_, v, vts, xe) : fundec) =                      | g ((_, v, vts, xe) : fundec) =
307                           chkIn(v, if isCand v then FunExp(od, map #1 vts, xe)                           chkIn(v, if isCand v then FunExp(map #1 vts, xe)
308                                    else StdExp)                                    else StdExp)
309                    val _ = app g fdecs                    val _ = app g fdecs
310                    val (ne, b) = loop e                    val (ne, b) = loop e
# Line 323  Line 313 
313                end                end
314            | APP(u, us) =>            | APP(u, us) =>
315                (case appInfo u                (case appInfo u
316                  of SOME(od', vs, e) =>                  of SOME(vs, e) =>
317                       let val ne = LET(vs, RET us, e)                       let val ne = LET(vs, RET us, e)
318                        in transform ((od, od', 0)::cfg) ne                        in loop ne
319                       end                       end
320                   | _ => (APP(lpsv u, map lpsv us), false))                   | _ => (APP(lpsv u, map lpsv us), false))
321    
322            | TFN(tfdec as (v, tvks, xe), e) =>            | TFN(tfdec as (v, tvks, xe), e) =>
323                lplet ((fn z => TFN((v, tvks,                lplet ((fn z => TFN((v, tvks,
324                                #1(transform ((DI.next d, DI.next od,                                #1(loop xe)), z)),
                                             k+1)::rcfg) xe)), z)),  
325                       true, v, StdExp, e)                       true, v, StdExp, e)
326            | TAPP(u, ts) => (TAPP(lpsv u, map tcf ts), true)            | TAPP(u, ts) => (TAPP(lpsv u, ts), true)
327    
328            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)
329                lplet ((fn z => CON(lpdc c, map tcf ts, lpsv u, v, z)),                lplet ((fn z => CON(lpdc c, ts, lpsv u, v, z)),
330                       true, v, ConExp(c,ts,u), e)                       true, v, ConExp(c,ts,u), e)
331            | SWITCH (v, cs, ces, oe) =>            | SWITCH (v, cs, ces, oe) =>
332                (case swiInfo(v, ces, oe)                (case swiInfo(v, ces, oe)
# Line 367  Line 356 
356                   | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),                   | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),
357                                    true, v, StdExp, e))                                    true, v, StdExp, e))
358    
359            | RAISE(v, ts) => (RAISE(lpsv v, map ltf ts), false)            | RAISE(v, ts) => (RAISE(lpsv v, ts), false)
360            | HANDLE(e, v) =>            | HANDLE(e, v) =>
361                let val (ne, b) = loop e                let val (ne, b) = loop e
362                 in if b then (ne, true)                 in if b then (ne, true)
# Line 378  Line 367 
367                let val (ne1, b1) = loop e1                let val (ne1, b1) = loop e1
368                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
369                 in (BRANCH(case (d,ts) of (NONE, []) => px                 in (BRANCH(case (d,ts) of (NONE, []) => px
370                                         | _ => (lpdt d, p, lt, map tcf ts),                                         | _ => (lpdt d, p, lt, ts),
371                            map lpsv vs, ne1, ne2), false)                            map lpsv vs, ne1, ne2), false)
372                end                end
373            | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>            | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>
374                lplet ((fn z => PRIMOP((case (dt, ts)                lplet ((fn z => PRIMOP((case (dt, ts)
375                                         of (NONE, []) => px                                         of (NONE, []) => px
376                                          | _ => (lpdt dt, p, lt, map tcf ts)),                                          | _ => (lpdt dt, p, lt, ts)),
377                                       map lpsv vs, v, z)),                                       map lpsv vs, v, z)),
378                       false (* isPure p *), v, StdExp, e))                       false (* isPure p *), v, StdExp, e))
379    
      in loop  
     end (* function transform *)  
   
380  val d = DI.top  val d = DI.top
381  val (fk, f, vts, e) = fdec  val (fk, f, vts, e) = fdec
382  in (fk, f, vts, #1 (transform [(d, d, 0)] e))  in (fk, f, vts, #1 (loop e))
383     before (Intmap.clear m; cleanUp())     before (Intmap.clear m; cleanUp())
384  end (* function lcontract *)  end (* function lcontract *)
385    

Legend:
Removed from v.196  
changed lines
  Added in v.197

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