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

Diff of /sml/trunk/src/compiler/FLINT/cps/convert.sml

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

revision 190, Thu Nov 19 21:01:17 1998 UTC revision 191, Fri Nov 20 02:01:27 1998 UTC
# Line 21  Line 21 
21        structure DI = DebIndex        structure DI = DebIndex
22        structure F  = FLINT        structure F  = FLINT
23        structure FU = FlintUtil        structure FU = FlintUtil
24          structure M  = IntmapF
25    
26        open CPS        open CPS
27  in  in
# Line 28  Line 29 
29  fun bug s = ErrorMsg.impossible ("Convert: " ^ s)  fun bug s = ErrorMsg.impossible ("Convert: " ^ s)
30  val say = Control.Print.say  val say = Control.Print.say
31  val mkv = fn _ => LV.mkLvar()  val mkv = fn _ => LV.mkLvar()
32    val cplv = LV.dupLvar
33  fun mkfn f = let val v = mkv() in f v end  fun mkfn f = let val v = mkv() in f v end
34  val ident = fn le => le  val ident = fn le => le
35  val OFFp0 = OFFp 0  val OFFp0 = OFFp 0
# Line 271  Line 273 
273  (* rttys : mcont -> cty list *)  (* rttys : mcont -> cty list *)
274  fun rttys (MCONT{ts, ...}) = ts  fun rttys (MCONT{ts, ...}) = ts
275    
 (* isEta : cexp * value list -> value option *)  
 fun isEta (APP(w, vl), ul) =  
       let fun h (x::xs, y::ys) =  
                   if (veq(x, y)) andalso (not (veq(w, y)))  
                   then h(xs, ys) else NONE  
             | h ([], []) = SOME w  
             | h _ = NONE  
        in h(ul, vl)  
       end  
   | isEta _ = NONE  
   
 (* preventEta : mcont -> (cexp -> cexp) * value *)  
 fun preventEta (MCONT{cnt=c, ts=ts}) =  
   let val vl = map mkv ts  
       val ul = map VAR vl  
       val b = c ul  
    in case isEta(b, ul)  
        of SOME w => (ident, w)  
         | NONE => let val f = mkv()  
                    in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)  
                   end  
   end (* function preventEta *)  
   
276  (***************************************************************************  (***************************************************************************
277   *                        THE MAIN FUNCTION                                *   *                        THE MAIN FUNCTION                                *
278   *                   convert : F.prog -> CPS.function                      *   *                   convert : F.prog -> CPS.function                      *
# Line 339  Line 318 
318       fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))       fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))
319         | newnames ([], []) = ()         | newnames ([], []) = ()
320         | newnames _ = bug "unexpected case in newnames"         | newnames _ = bug "unexpected case in newnames"
321    
322         (* isEta : cexp * value list -> value option *)
323         fun isEta (APP(w as VAR lv, vl), ul) =
324             (* If the function is in the global renaming table and it's
325              * renamed to itself, then it's most likely a while loop and
326              * should *not* be eta-reduced *)
327             if ((case Intmap.map m lv of VAR lv' => lv = lv' | _ => false)
328                     handle Rename => false) then NONE else
329                 let fun h (x::xs, y::ys) =
330                         if (veq(x, y)) andalso (not (veq(w, y)))
331                         then h(xs, ys) else NONE
332                       | h ([], []) = SOME w
333                       | h _ = NONE
334                 in h(ul, vl)
335                 end
336           | isEta _ = NONE
337    
338       end (* local of Rename *)       end (* local of Rename *)
339    
340         (* preventEta : mcont -> (cexp -> cexp) * value *)
341         fun preventEta (MCONT{cnt=c, ts=ts}) =
342             let val vl = map mkv ts
343                 val ul = map VAR vl
344                 val b = c ul
345             in case isEta(b, ul)
346                 of SOME w => (ident, w)
347                  | NONE => let val f = mkv()
348                    in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)
349                    end
350             end (* function preventEta *)
351    
352       (* switch optimization *)       (* switch optimization *)
353       val do_switch = do_switch_gen rename       val do_switch = do_switch_gen rename
354    
# Line 364  Line 372 
372          in h(vl, [])          in h(vl, [])
373         end         end
374    
      (* lpfd : F.fundec -> function *)  
      fun lpfd ((fk, f, vts, e) : F.fundec) =  
        let val k = mkv()  
            val vl = k::(map #1 vts)  
            val cl = CNTt::(map (ctype o #2) vts)  
            val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)  
         in (ESCAPE, f, vl, cl, loop(e, kont))  
        end  
   
375       (* loop : F.lexp * (value list -> cexp) -> cexp *)       (* loop : F.lexp * (value list -> cexp) -> cexp *)
376       and loop (le, c) =       fun loop' m (le, c) = let val loop = loop' m
377         (case le       in case le
378           of F.RET vs => appmc(c, lpvars vs)           of F.RET vs => appmc(c, lpvars vs)
379            | F.LET(vs, e1, e2) =>            | F.LET(vs, e1, e2) =>
380                let val kont =                let val kont =
# Line 384  Line 383 
383                 in loop(e1, kont)                 in loop(e1, kont)
384                end                end
385    
386            | F.FIX(fds, e) => FIX(map lpfd fds, loop(e, c))            | F.FIX(fds, e) =>
387            | F.APP(f, vs) =>              (* lpfd : F.fundec -> function *)
388                let fun lpfd ((fk, f, vts, e) : F.fundec) =
389                        let val k = mkv()
390                            val cl = CNTt::(map (ctype o #2) vts)
391                            val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
392                            val (vl,body) =
393                                case fk
394                                 of {isrec=SOME(_,F.LK_WHILE),...} => let
395                                     (* for tail recursive loops, we create a
396                                      * local function that takes its continuation
397                                      * from the environment *)
398                                     val f' = cplv f
399                                     (* here we add a dumb entry for f' in the
400                                      * global renaming table just so that isEta
401                                      * can avoid eta-reducing it *)
402                                     val _ = newname(f', VAR f')
403                                     val vl = k::(map (cplv o #1) vts)
404                                     val vl' = map #1 vts
405                                     val cl' = map (ctype o #2) vts
406                                 in
407                                     (vl,
408                                      FIX([(KNOWN_TAIL, f', vl', cl',
409                                            (* add the function to the tail map *)
410                                            loop' (M.add(m,f,f')) (e, kont))],
411                                          APP(VAR f', map VAR (tl vl))))
412                                 end
413                                  | _ => (k::(map #1 vts), loop(e, kont))
414                        in (ESCAPE, f, vl, cl, body)
415                        end
416                in FIX(map lpfd fds, loop(e, c))
417                end
418              | F.APP(f as F.VAR lv, vs) =>
419                (* first check if it's a recursive call to a tail loop *)
420                (let val f' = M.lookup m lv
421                in APP(VAR f', lpvars vs)
422                end handle M.IntmapF =>
423                         (* code for the non-tail case.
424                          * Sadly this is *not* exceptional *)
425                let val (hdr, F) = preventEta c                let val (hdr, F) = preventEta c
426                    val vf = lpvar f                    val vf = lpvar f
427                    val ul = lpvars vs                    val ul = lpvars vs
428                 in hdr(APP(vf, F::ul))                 in hdr(APP(vf, F::ul))
429                end                       end)
430              | F.APP _ => bug "unexpected APP in convert"
431    
432            | (F.TFN _ | F.TAPP _) =>            | (F.TFN _ | F.TAPP _) =>
433                bug "unexpected TFN and TAPP in convert"                bug "unexpected TFN and TAPP in convert"
# Line 567  Line 604 
604                    val kont = makmc(fn vl => APP(F, vl), rttys c)                    val kont = makmc(fn vl => APP(F, vl), rttys c)
605                 in hdr(BRANCH(map_branch p, lpvars ul, mkv(),                 in hdr(BRANCH(map_branch p, lpvars ul, mkv(),
606                               loop(e1, kont), loop(e2, kont)))                               loop(e1, kont), loop(e2, kont)))
607                end)                end
608         end
609    
610      (* processing the top-level fundec *)      (* processing the top-level fundec *)
611      val (fk, f, vts, be) = fdec      val (fk, f, vts, be) = fdec
612      val k = mkv()    (* top-level return continuation *)      val k = mkv()    (* top-level return continuation *)
613      val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)      val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
614      val body = loop(be, kont)      val body = loop' M.empty (be, kont)
615    
616      val vl = k::(map #1 vts)      val vl = k::(map #1 vts)
617      val cl = CNTt::(map (ctype o #2) vts)      val cl = CNTt::(map (ctype o #2) vts)

Legend:
Removed from v.190  
changed lines
  Added in v.191

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