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
 [smlnj] / sml / trunk / src / compiler / FLINT / opt / fcontract.sml

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

revision 196, Fri Nov 20 18:16:19 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 200  Line 200
200
201  datatype sval  datatype sval
202    = Val    of F.value                   (* F.value should never be F.VAR lv *)    = Val    of F.value                   (* F.value should never be F.VAR lv *)
203    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind
204    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list
205    | Record of F.lvar * sval list    | Record of F.lvar * sval list
206    | Con    of F.lvar * sval * F.dcon * F.tyc list    | Con    of F.lvar * sval * F.dcon * F.tyc list
207    | Decon  of F.lvar * sval * F.dcon * F.tyc list    | Decon  of F.lvar * sval * F.dcon * F.tyc list
# Line 266  Line 266
266   * ifs (inlined functions): records which functions we're currently inlining   * ifs (inlined functions): records which functions we're currently inlining
267   *     in order to detect loops   *     in order to detect loops
268   * m: is a map lvars to their defining expressions (svals) *)   * m: is a map lvars to their defining expressions (svals) *)
269  fun cexp (cfg as (d,od)) ifs m le cont = let  fun cexp ifs m le cont = let
270
271      val loop = cexp cfg ifs      val loop = cexp ifs
272
273      fun used lv = (C.usenb(C.get lv) > 0)      fun used lv = (C.usenb(C.get lv) > 0)
274                        handle x =>                        handle x =>
# Line 318  Line 318
318          in case lookup m lv          in case lookup m lv
319              of Var {1=nlv,...}   => ()              of Var {1=nlv,...}   => ()
320               | Val v             => ()               | Val v             => ()
321               | Fun (lv,le,args,_,_) =>               | Fun (lv,le,args,_) =>
322                 C.unuselexp undertake                 C.unuselexp undertake
323                             (F.LET(map #1 args,                             (F.LET(map #1 args,
324                                    F.RET (map (fn _ => F.INT 0) args),                                    F.RET (map (fn _ => F.INT 0) args),
# Line 380  Line 380
380       *)       *)
381      fun inline ifs (f,vs) =      fun inline ifs (f,vs) =
382          case ((val2sval m f) handle x => raise x)          case ((val2sval m f) handle x => raise x)
383           of Fun(g,body,args,{inline,...},od) =>           of Fun(g,body,args,{inline,...}) =>
384              (if d <> od then (NONE, ifs)              (if ((C.usenb(C.get g))handle x => raise x) = 1 andalso not(S.member ifs g) then
else if ((C.usenb(C.get g))handle x => raise x) = 1 andalso not(S.member ifs g) then
385
386                   (* simple inlining:  we should copy the body and then                   (* simple inlining:  we should copy the body and then
387                    * kill the function, but instead we just move the body                    * kill the function, but instead we just move the body
# Line 391  Line 390
390                    * see comments at the begining of this file and in cfun *)                    * see comments at the begining of this file and in cfun *)
391                   (click_simpleinline();                   (click_simpleinline();
392                    ignore(C.unuse true (C.get g));                    ignore(C.unuse true (C.get g));
393                    (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))                    (SOME(F.LET(map #1 args, F.RET vs, body)), ifs))
394
395               (* aggressive inlining (but hopefully safe).  We allow               (* aggressive inlining (but hopefully safe).  We allow
396                * inlining for mutually recursive functions (isrec)                * inlining for mutually recursive functions (isrec)
# Line 417  Line 416
416                       (*  say ("\nInlining "^(C.LVarString g)); *)                       (*  say ("\nInlining "^(C.LVarString g)); *)
417                       (app (unuseval m) vs) handle x => raise x;                       (app (unuseval m) vs) handle x => raise x;
418                       unusecall m g;                       unusecall m g;
419                       (SOME(nle, od),                       (SOME nle,
420                        (* gross hack: to prevent further unrolling,                        (* gross hack: to prevent further unrolling,
421                         * I pretend that the rest is not inside the body *)                         * I pretend that the rest is not inside the body *)
422                        if inline = F.IH_UNROLL                        if inline = F.IH_UNROLL
# Line 505  Line 504
505                          val nm = foldl addnobind m args                          val nm = foldl addnobind m args
506                          (* contract the body and create the resulting fundec *)                          (* contract the body and create the resulting fundec *)
507                          val nbody = cexp cfg (S.add(f, ifs)) nm body #2                          val nbody = cexp (S.add(f, ifs)) nm body #2
508                          (* if inlining took place, the body might be completely                          (* if inlining took place, the body might be completely
509                           * changed (read: bigger), so we have to reset the                           * changed (read: bigger), so we have to reset the
510                           * `inline' bit *)                           * `inline' bit *)
# Line 520  Line 519
519                           * gets inlined afterwards, the counts will reflect the                           * gets inlined afterwards, the counts will reflect the
520                           * new contracted code while we'll be working on the                           * new contracted code while we'll be working on the
521                           * the old uncontracted code *)                           * the old uncontracted code *)
522                          val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))                          val nm = addbind(m, f, Fun(f, nbody, args, nfk))
523                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)
524                             (*  before say ("\nExiting "^(C.LVarString f)) *)                             (*  before say ("\nExiting "^(C.LVarString f)) *)
525                      end                      end
# Line 617  Line 616
616
617              (* register the new bindings (uncontracted for now) *)              (* register the new bindings (uncontracted for now) *)
618              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
619                              addbind(m, f, Fun(f, body, args, fk, od)))                              addbind(m, f, Fun(f, body, args, fk)))
620                             m fs                             m fs
621              (* check for eta redexes *)              (* check for eta redexes *)
622              val (nm,fs,_) = foldl ceta (nm,[],[]) fs              val (nm,fs,_) = foldl ceta (nm,[],[]) fs
# Line 648  Line 647
647        | F.APP (f,vs) =>        | F.APP (f,vs) =>
648          let val nvs = ((map substval vs) handle x => raise x)          let val nvs = ((map substval vs) handle x => raise x)
649          in case inline ifs (f, nvs)          in case inline ifs (f, nvs)
650              of (SOME(le,od),nifs) => cexp (d,od) nifs m le cont              of (SOME le,nifs) => cexp nifs m le cont
651               | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))               | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
652          end          end
653
654        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
655          let val fi = C.get f          let val fi = C.get f
656          in if C.dead fi then (click_deadlexp(); loop m le cont) else          in if C.dead fi then (click_deadlexp(); loop m le cont) else
657              let val nbody = cexp (DI.next d, DI.next od) ifs m body #2              let val nbody = cexp ifs m body #2
658                  val nm = addbind(m, f, TFun(f, nbody, args, od))                  val nm = addbind(m, f, TFun(f, nbody, args))
659                  val nle = loop nm le cont                  val nle = loop nm le cont
660              in              in
661                  if C.dead fi then nle else F.TFN((f, args, nbody), nle)                  if C.dead fi then nle else F.TFN((f, args, nbody), nle)
# Line 870  Line 869
869
870  in  in
871      (*  C.collect fdec; *)      (*  C.collect fdec; *)
872      case cexp (DI.top,DI.top) S.empty      case cexp S.empty
873                M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2                M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
874       of F.FIX([fdec], F.RET[F.VAR f]) => fdec       of F.FIX([fdec], F.RET[F.VAR f]) => fdec
875        | fdec => bug "invalid return fundec"        | fdec => bug "invalid return fundec"

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