[MLton-commit] r5787

Matthew Fluet fluet at mlton.org
Tue Jul 24 19:58:07 PDT 2007


Some cosmetic improvements to profiling
----------------------------------------------------------------------

U   mlton/trunk/mlton/core-ml/core-ml.fun
U   mlton/trunk/mlton/core-ml/core-ml.sig
U   mlton/trunk/mlton/defunctorize/defunctorize.fun
U   mlton/trunk/mlton/elaborate/elaborate-core.fun
U   mlton/trunk/mlton/elaborate/elaborate-env.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/core-ml/core-ml.fun
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.fun	2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/core-ml/core-ml.fun	2007-07-25 02:58:05 UTC (rev 5787)
@@ -151,6 +151,7 @@
            tyvars: unit -> Tyvar.t vector,
            vbs: {exp: exp,
                  lay: unit -> Layout.t,
+                 nest: string list,
                  pat: Pat.t,
                  patRegion: Region.t} vector}
 and exp = Exp of {node: expNode,
@@ -159,6 +160,7 @@
    App of exp * exp
   | Case of {kind: string,
              lay: unit -> Layout.t,
+             nest: string list,
              noMatch: noMatch,
              nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
              nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -365,6 +367,7 @@
       fun iff (test, thenCase, elseCase): t =
          casee {kind = "if",
                 lay = fn () => Layout.empty,
+                nest = [],
                 noMatch = Impossible,
                 nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
                 nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,

Modified: mlton/trunk/mlton/core-ml/core-ml.sig
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.sig	2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/core-ml/core-ml.sig	2007-07-25 02:58:05 UTC (rev 5787)
@@ -74,6 +74,7 @@
                App of t * t
              | Case of {kind: string,
                         lay: unit -> Layout.t,
+                        nest: string list,
                         noMatch: noMatch,
                         nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
                         nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -103,6 +104,7 @@
             val andAlso: t * t -> t
             val casee: {kind: string,
                         lay: unit -> Layout.t,
+                        nest: string list,
                         noMatch: noMatch,
                         nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
                         nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -166,6 +168,7 @@
                        tyvars: unit -> Tyvar.t vector,
                        vbs: {exp: Exp.t,
                              lay: unit -> Layout.t,
+                             nest: string list,
                              pat: Pat.t,
                              patRegion: Region.t} vector}
 

Modified: mlton/trunk/mlton/defunctorize/defunctorize.fun
===================================================================
--- mlton/trunk/mlton/defunctorize/defunctorize.fun	2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/defunctorize/defunctorize.fun	2007-07-25 02:58:05 UTC (rev 5787)
@@ -110,6 +110,7 @@
            conTycon,
            kind: string,
            lay: unit -> Layout.t,
+           nest: string list,
            noMatch,
            nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
            nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -130,17 +131,21 @@
             val exp = Xexp.raisee (f e, {extend = true}, caseType)
             val exp =
                fn () =>
-               if mayWrap andalso
-                  let
+               if let
                      open Control
                   in
                      !profile <> ProfileNone 
                      andalso !profileIL = ProfileSource
                      andalso !profileRaise
                   end
-                  then enterLeave (exp, caseType,
-                                   SourceInfo.function {name = ["raise"],
-                                                        region = region})
+                  then case mayWrap of
+                          NONE => exp
+                        | SOME kind => 
+                             enterLeave 
+                             (exp, caseType,
+                              SourceInfo.function 
+                              {name = (concat ["<raise ", kind, ">"]) :: nest,
+                               region = region})
                else exp
          in
             Vector.concat
@@ -158,9 +163,9 @@
             case noMatch of
                Impossible => cases
              | RaiseAgain =>
-                  raiseExn (fn e => Xexp.monoVar (e, Xtype.exn), false)
-             | RaiseBind => raiseExn (fn _ => Xexp.bind, true)
-             | RaiseMatch => raiseExn (fn _ => Xexp.match, true)
+                  raiseExn (fn e => Xexp.monoVar (e, Xtype.exn), NONE)
+             | RaiseBind => raiseExn (fn _ => Xexp.bind, SOME "Bind")
+             | RaiseMatch => raiseExn (fn _ => Xexp.match, SOME "Match")
          end
       val examples = ref (fn () => Vector.new0 ())
       fun matchCompile () =                                  
@@ -730,7 +735,7 @@
                   val bodyType = et
                   val e =
                      Vector.foldr
-                     (vbs, e, fn ({exp, lay, pat, patRegion}, e) =>
+                     (vbs, e, fn ({exp, lay, nest, pat, patRegion}, e) =>
                       let
                          fun patDec (p: NestedPat.t,
                                      e: Xexp.t,
@@ -744,6 +749,7 @@
                                    conTycon = conTycon,
                                    kind = "declaration",
                                    lay = lay,
+                                   nest = nest,
                                    noMatch = Cexp.RaiseBind,
                                    nonexhaustiveExnMatch = nonexhaustiveExnMatch,
                                    nonexhaustiveMatch = if mayWarn
@@ -935,7 +941,7 @@
                                         func = #1 (loopExp e1),
                                         ty = ty}
                      end
-                | Case {kind, lay, noMatch,
+                | Case {kind, lay, nest, noMatch,
                         nonexhaustiveExnMatch, nonexhaustiveMatch, redundantMatch, 
                         region, rules, test, ...} =>
                      casee {caseType = ty,
@@ -946,6 +952,7 @@
                             conTycon = conTycon,
                             kind = kind,
                             lay = lay,
+                            nest = nest,
                             noMatch = noMatch,
                             nonexhaustiveExnMatch = nonexhaustiveExnMatch,
                             nonexhaustiveMatch = nonexhaustiveMatch,

Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun	2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun	2007-07-25 02:58:05 UTC (rev 5787)
@@ -376,16 +376,28 @@
       else ()
 end
 
-fun approximate (l: Layout.t): Layout.t =
+fun approximateN (l: Layout.t, prefixMax, suffixMax): Layout.t =
    let
       val s = Layout.toString l
       val n = String.size s
    in
       Layout.str
-      (if n <= 60
-          then s
-       else concat [String.prefix (s, 35), "  ...  ", String.suffix (s, 25)])
+      (case suffixMax of
+          NONE =>
+             if n <= prefixMax
+                then s
+             else concat [String.prefix (s, prefixMax - 5), "  ..."]
+        | SOME suffixMax =>
+             if n <= prefixMax + suffixMax
+                then s
+             else concat [String.prefix (s, prefixMax - 2), 
+                          "  ...  ",
+                          String.suffix (s, suffixMax - 5)])
    end
+fun approximate (l: Layout.t): Layout.t =
+   approximateN (l, 35, SOME 25)
+fun approximatePrefix (l: Layout.t): Layout.t =
+   approximateN (l, 15, NONE)
 
 val elaboratePat:
    unit
@@ -974,6 +986,7 @@
          if not isBool then fetchExp else
          Cexp.casee {kind = "",
                      lay = fn () => Layout.empty,
+                     nest = [],
                      noMatch = Cexp.Impossible,
                      nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
                      nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
@@ -995,6 +1008,7 @@
             if not isBool then valueExp else
             Cexp.casee {kind = "",
                         lay = fn () => Layout.empty,
+                        nest = [],
                         noMatch = Cexp.Impossible,
                         nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
                         nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
@@ -1869,9 +1883,22 @@
                                          profileBody 
                                          andalso !Control.profileBranch,
                                          fn () =>
-                                         SourceInfo.function
-                                         {name = "<branch>" :: nest,
-                                          region = bodyRegion})
+                                         let
+                                            open Layout
+                                            val name =
+                                               concat ["<case ",
+                                                       Layout.toString
+                                                       (approximatePrefix
+                                                        (seq
+                                                         (separateRight 
+                                                          (Vector.toListMap 
+                                                           (args, Apat.layout), " ")))),
+                                                       ">"]
+                                         in
+                                            SourceInfo.function
+                                            {name = name :: nest,
+                                             region = bodyRegion}
+                                         end)
                                      val _ =
                                         Option.app
                                         (resultType, fn t =>
@@ -1941,6 +1968,7 @@
                                             Cexp.casee
                                             {kind = "function",
                                              lay = lay,
+                                             nest = nest,
                                              noMatch = Cexp.RaiseMatch,
                                              nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
                                              nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -2092,6 +2120,23 @@
                              val patRegion = Apat.region pat
                              val expRegion = Aexp.region exp
                              val exp = elabExp (exp, nest, Apat.getName pat)
+                             val exp =
+                                Cexp.enterLeave
+                                (exp, 
+                                 profileBody 
+                                 andalso !Control.profileVal
+                                 andalso Cexp.isExpansive exp, fn () =>
+                                 let
+                                    val name =
+                                       concat ["<val ",
+                                               Layout.toString
+                                               (approximatePrefix
+                                                (Apat.layout pat)),
+                                               ">"]
+                                 in
+                                    SourceInfo.function {name = name :: nest,
+                                                         region = expRegion}
+                                 end)
                           in
                              {exp = exp,
                               expRegion = expRegion,
@@ -2160,6 +2205,7 @@
                                 Cexp.enterLeave
                                 (Cexp.casee {kind = "function",
                                              lay = lay,
+                                             nest = nest,
                                              noMatch = Cexp.RaiseMatch,
                                              nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
                                              nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -2207,27 +2253,6 @@
                                   align [seq [str "pattern:    ", p],
                                          seq [str "expression: ", e],
                                          lay ()]))
-                             val exp =
-                                Cexp.enterLeave
-                                (exp, 
-                                 profileBody 
-                                 andalso !Control.profileVal 
-                                 andalso Cexp.isExpansive exp, fn () =>
-                                 let
-                                    val bound = Vector.map (bound, #1)
-                                    val name = 
-                                       concat ["<val>:",
-                                               if Vector.length bound = 1
-                                                  then (Avar.toString 
-                                                        (Vector.sub (bound, 0)))
-                                               else (Vector.toString 
-                                                     Avar.toString 
-                                                     bound)]
-                                 in
-                                    SourceInfo.function
-                                    {name = name :: nest,
-                                     region = expRegion}
-                                 end)
                           in
                              {bound = bound,
                               exp = exp,
@@ -2266,6 +2291,7 @@
                          Vector.map (vbs, fn {exp, lay, pat, patRegion, ...} =>
                                      {exp = exp,
                                       lay = lay,
+                                      nest = nest,
                                       pat = pat,
                                       patRegion = patRegion})
                       (* According to page 28 of the Definition, we should
@@ -2357,6 +2383,7 @@
                    in
                       Cexp.casee {kind = "case",
                                   lay = lay,
+                                  nest = nest,
                                   noMatch = Cexp.RaiseMatch,
                                   nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
                                   nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -2462,7 +2489,7 @@
                                    {name = name :: nest,
                                     region = Aexp.region e})
                             in
-                               (wrap (b, b', "<true>"), wrap (c, c', "<false>"))
+                               (wrap (b, b', "<case true>"), wrap (c, c', "<case false>"))
                             end
                    in
                       Cexp.iff (a', b', c')
@@ -2556,6 +2583,7 @@
                                               Cexp.casee
                                               {kind = "",
                                                lay = fn _ => Layout.empty,
+                                               nest = [],
                                                noMatch = Cexp.Impossible,
                                                nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
                                                nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
@@ -3042,6 +3070,7 @@
             val body =
                Cexp.casee {kind = kind,
                            lay = lay,
+                           nest = nest,
                            noMatch = noMatch,
                            nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
                            nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -3073,37 +3102,48 @@
                           approximate
                           (seq [Apat.layout pat, str " => ", Aexp.layout exp])
                        end
-                    val (p, _) =
+                    val patOrig = pat
+                    val (pat, _) =
                        elaboratePat () (pat, E, {bind = true, isRvb = false},
                                         preError)
                     val _ =
                        unify
-                       (Cpat.ty p, argType, preError, fn (l1, l2) =>
-                        (Apat.region pat,
+                       (Cpat.ty pat, argType, preError, fn (l1, l2) =>
+                        (Apat.region patOrig,
                          str "rule patterns disagree",
                          align [seq [str "pattern:  ", l1],
                                 seq [str "previous: ", l2],
                                 seq [str "in: ", lay ()]]))
-                    val e = elabExp (exp, nest, NONE)
+                    val expOrig = exp
+                    val exp = elabExp (exp, nest, NONE)
                     val _ =
                        unify
-                       (Cexp.ty e, resultType, preError, fn (l1, l2) =>
-                        (Aexp.region exp,
+                       (Cexp.ty exp, resultType, preError, fn (l1, l2) =>
+                        (Aexp.region expOrig,
                          str "rule results disagree",
                          align [seq [str "result:   ", l1],
                                 seq [str "previous: ", l2],
                                 seq [str "in: ", lay ()]]))
-                    val e =
+                    val exp =
                        Cexp.enterLeave
-                       (e, 
-                        profileBody andalso !Control.profileBranch, 
+                       (exp, 
+                        profileBody andalso !Control.profileBranch,
                         fn () =>
-                        SourceInfo.function {name = "<branch>" :: nest,
-                                             region = Aexp.region exp})
+                        let
+                           val name =
+                              concat ["<case ",
+                                      Layout.toString
+                                      (approximatePrefix
+                                       (Apat.layout patOrig)),
+                                      ">"]
+                        in
+                           SourceInfo.function {name = name :: nest,
+                                                region = Aexp.region expOrig}
+                        end)
                  in
-                    {exp = e,
+                    {exp = exp,
                      lay = SOME lay,
-                     pat = p}
+                     pat = pat}
                  end))
          in
             {argType = argType,

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-07-25 02:58:05 UTC (rev 5787)
@@ -2917,6 +2917,7 @@
                                             vbs = (Vector.new1
                                                    {exp = e,
                                                     lay = fn _ => Layout.empty,
+                                                    nest = [],
                                                     pat = Pat.var (x, strType),
                                                     patRegion = region})})
                             in




More information about the MLton-commit mailing list