Pretty print reasons for Many wip/T10613
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 6 Jul 2016 13:44:07 +0000 (15:44 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 6 Jul 2016 13:44:07 +0000 (15:44 +0200)
47 files changed:
card-count.pl [new file with mode: 0755]
compiler/basicTypes/Demand.hs
compiler/basicTypes/IdInfo.hs
compiler/basicTypes/MkId.hs
compiler/cmm/CLabel.hs
compiler/cmm/CmmType.hs
compiler/cmm/SMRep.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmTicky.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CoreArity.hs
compiler/coreSyn/CorePrep.hs
compiler/coreSyn/PprCore.hs
compiler/ghci/ByteCodeItbls.hs
compiler/prelude/primops.txt.pp
compiler/simplStg/StgStats.hs
compiler/specialise/SpecConstr.hs
compiler/stgSyn/CoreToStg.hs
compiler/stgSyn/StgSyn.hs
compiler/stranal/DmdAnal.hs
compiler/stranal/WorkWrap.hs
includes/rts/Ticky.h
includes/rts/storage/ClosureMacros.h
includes/rts/storage/ClosureTypes.h
includes/rts/storage/Closures.h
includes/stg/MiscClosures.h
rts/CheckUnload.c
rts/ClosureFlags.c
rts/Interpreter.c
rts/LdvProfile.c
rts/Printer.c
rts/ProfHeap.c
rts/RetainerProfile.c
rts/RtsSymbols.c
rts/Stable.c
rts/StgMiscClosures.cmm
rts/Ticky.c
rts/sm/Compact.c
rts/sm/Evac.c
rts/sm/GCAux.c
rts/sm/Sanity.c
rts/sm/Scav.c
utils/deriveConstants/Main.hs
utils/genapply/Main.hs

diff --git a/card-count.pl b/card-count.pl
new file mode 100755 (executable)
index 0000000..49a43ae
--- /dev/null
@@ -0,0 +1,166 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+
+my $reading = 0;
+
+# key: 1 <=> single entry (first static then dynamic)
+my %thunk_counts = (
+        0 => {0 => 0, 1 => 0, 2=>0 },
+       1 => {0 => 0, 1 => 0, 2=>0 },
+ );
+my %dyn_thunk_counts = (
+        0 => {0 => 0, 1 => 0, 2=>0 },
+       1 => {0 => 0, 1 => 0, 2=>0 },
+ );
+my %fun_counts = (
+        0 => {0 => 0, 1 => 0, 2=>0 },
+       1 => {0 => 0, 1 => 0, 2=>0 },
+ );
+
+my %reason_counts = ();
+my %unique_reason_counts = ();
+
+my @interesting;
+
+while (<>) {
+       if ($reading and /^$/) {$reading = 0};
+       if (not $reading and /^----------------/) {$reading = 1; next;};
+       next unless $reading;
+
+       if (m/^
+                \s+
+                (?<entries>\d+)\s+
+                (?<alloc>\d+)\s+
+                (?<alloced>\d+)\s+
+                (?<nalloc>\d+)\s+
+                (?<single>\d+)\s+
+                (?<multiple>\d+)\s+
+                (?<args>\d+)\s+
+                (?<rest>.*)
+               /nx)
+       {
+               my %vals = %+;
+
+
+               # ignore constructors
+               next if $vals{rest} =~ m/\(con\)/;
+
+
+               # ignore never allocated things
+               next if $vals{nalloc} == 0;
+
+               # ignore static or dead entries
+               #next if $vals{single} + $vals{multiple} == 0;
+
+               my ($flags)      = ($vals{rest} =~ m/\((?:thk|fun)(.*)\)/);
+               my ($manyreasons) = ($flags =~ m/\((.*)\)/);
+               $manyreasons ||= "";
+               my @manyreasons = split ",",$manyreasons;
+
+               my $thk = $vals{rest} =~ m/\(thk/;
+               my $static_se = $flags =~ m/,se/ ? 1 : 0;
+               my $boring = 0;
+               my $dynamic_se = $vals{multiple} == 0 ? 1 : 0;
+               my $dynamic_dead = ($vals{single} + $vals{multiple} == 0) ? 1 : 0;
+
+               if ($thk) {
+                       $thunk_counts{$static_se}{$dynamic_se + $dynamic_dead}++;
+                       $dyn_thunk_counts{$static_se}{$dynamic_se + $dynamic_dead} += $vals{nalloc};
+               } else {
+                       $fun_counts{$static_se}{$dynamic_se + $dynamic_dead}++;
+               }
+
+               if ($thk and $dynamic_se and not $static_se and not $boring) {
+                       $reason_counts{$_} += $vals{nalloc} for @manyreasons;
+                       if (@manyreasons > 1) {
+                               $unique_reason_counts{various} += $vals{nalloc};
+                       } else {
+                               $unique_reason_counts{$manyreasons[0]} += $vals{nalloc};
+                       }
+                       push @interesting, { n => $vals{single}, desc => $vals{rest}};
+               }
+       } else {
+               print "Could not parse $_"
+       }
+}
+
+sub print_table {
+       my ($title, $tab) = @_;
+
+       printf <<__END__,
+%s:
+             |  Static s.e. |       Normal |          Sum
+Dynamic dead  | %12d | %12d | %12d (Proportion: %4.1f%%)
+Dynamic s.e.  | %12d | %12d | %12d (Proportion: %4.1f%%)
+Multi entries | %12d | %12d | %12d
+Sum           | %12d | %12d | %12d
+
+__END__
+               $title,
+               $tab->{1}{2},
+               $tab->{0}{2},
+               $tab->{1}{2} + $tab->{0}{2},
+               ($tab->{1}{2} + $tab->{0}{2}) ? ($tab->{1}{2} / ($tab->{1}{2} + $tab->{0}{2}) * 100) : 0,
+               $tab->{1}{1},
+               $tab->{0}{1},
+               $tab->{1}{1} + $tab->{0}{1},
+               ($tab->{1}{1} + $tab->{0}{1}) ? ($tab->{1}{1} / ($tab->{1}{1} + $tab->{0}{1}) * 100) : 0,
+               $tab->{1}{0},
+               $tab->{0}{0},
+               $tab->{1}{0} + $tab->{0}{0},
+               $tab->{1}{2} + $tab->{1}{1} + $tab->{1}{0},
+               $tab->{0}{2} + $tab->{0}{1} + $tab->{0}{0},
+               $tab->{1}{2} + $tab->{0}{2} + $tab->{1}{1} + $tab->{0}{1} + $tab->{1}{0} + $tab->{0}{0};
+
+}
+
+print_table ("Thunks (counted per info table)", \%thunk_counts);
+print_table ("Thunks (counted per dynamically allocated instance)", \%dyn_thunk_counts);
+print_table ("Functions", \%fun_counts);
+
+@interesting = sort { $b->{n} <=> $a->{n} } @interesting;
+
+# srsly? should have used Haskell...
+sub max ($$) { $_[$_[0] < $_[1]] }
+sub min ($$) { $_[$_[0] > $_[1]] }
+
+
+printf <<__END__;
+Interesting missed opportunities:
+__END__
+
+for (@interesting[0..min(10,$#interesting)]) {
+       printf "%10d: %s\n", $_->{n}, $_->{desc};
+}
+
+my $total = $dyn_thunk_counts{0}{1} + $dyn_thunk_counts{0}{2};
+
+my @reason_counts = ();
+push @reason_counts, { reason => $_, n => $reason_counts{$_} } foreach keys %reason_counts ;
+@reason_counts = sort { $b->{n} <=> $a->{n} } @reason_counts;
+
+printf <<__END__;
+Most common reasons
+__END__
+
+for (@reason_counts[0..min(99,$#reason_counts)]) {
+       printf "%10d: (%4.1f%%) %s\n", $_->{n}, $_->{n} / $total * 100, $_->{reason};
+}
+
+
+my @unique_reason_counts = ();
+push @unique_reason_counts, { reason => $_, n => $unique_reason_counts{$_} } foreach keys %unique_reason_counts ;
+@unique_reason_counts = sort { $b->{n} <=> $a->{n} } @unique_reason_counts;
+
+printf <<__END__;
+Most common unique reasons
+__END__
+
+for (@unique_reason_counts[0..min(99,$#unique_reason_counts)]) {
+       printf "%10d: (%4.1f%%) %s\n", $_->{n}, $_->{n} / $total * 100,  $_->{reason};
+}
+
+
index 1ca65b0..03be236 100644 (file)
@@ -8,13 +8,12 @@
 {-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}
 
 module Demand (
-        StrDmd, UseDmd(..), Count(..),
-        countOnce, countMany,   -- cardinality
+        StrDmd, UseDmd(..), Count,
 
         Demand, CleanDemand, getStrDmd, getUseDmd,
         mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
         toCleanDmd,
-        absDmd, topDmd, botDmd, seqDmd,
+        absDmd, topDmd, boringTopDmd, botDmd, seqDmd,
         lubDmd, bothDmd,
         lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,
         catchArgDmd,
@@ -51,7 +50,7 @@ module Demand (
         argOneShots, argsOneShots, saturatedByOneShots,
         trimToType, TypeShape(..),
 
-        useCount, isUsedOnce, reuseEnv,
+        useCount, isUsedOnce, isBoringDemand, reuseEnv,
         killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,
         zapUsedOnceDemand, zapUsedOnceSig,
         strictifyDictDmd
@@ -60,6 +59,8 @@ module Demand (
 
 #include "HsVersions.h"
 
+import Data.List (nub, sort)
+
 import DynFlags
 import Outputable
 import Var ( Var )
@@ -68,6 +69,7 @@ import UniqFM
 import Util
 import BasicTypes
 import Binary
+import FastString
 import Maybes           ( orElse )
 
 import Type            ( Type, isUnliftedType )
@@ -358,15 +360,24 @@ data Use u
   | Use Count u     -- May be used with some cardinality
   deriving ( Eq, Show )
 
+-- Lets be lazy here and use strings, instead of a proper data type
+type ManyReasons = [String]
+
+normManyReasons :: ManyReasons -> ManyReasons
+normManyReasons = nub . sort
+
+lubManyReasons :: ManyReasons -> ManyReasons -> ManyReasons
+lubManyReasons mr1 mr2 = normManyReasons $ mr1 ++ mr2
+
 -- Abstract counting of usages
-data Count = One | Many
+-- Bool argument: True <=> Many for a good reason
+data Count = One | Many ManyReasons
   deriving ( Eq, Show )
 
 -- Pretty-printing
 instance Outputable ArgUse where
-  ppr Abs           = char 'A'
-  ppr (Use Many a)   = ppr a
-  ppr (Use One  a)   = char '1' <> char '*' <> ppr a
+  ppr Abs              = char 'A'
+  ppr (Use c  a)       = ppr c <> char '*' <> ppr a
 
 instance Outputable UseDmd where
   ppr Used           = char 'U'
@@ -376,16 +387,11 @@ instance Outputable UseDmd where
 
 instance Outputable Count where
   ppr One  = char '1'
-  ppr Many = text ""
-
--- Well-formedness preserving constructors for the Absence domain
-countOnce, countMany :: Count
-countOnce = One
-countMany = Many
+  ppr (Many mr) = text "ω" <> parens (hcat (punctuate (char ',') (map text mr)))
 
 useBot, useTop :: ArgUse
 useBot     = Abs
-useTop     = Use Many Used
+useTop     = Use (Many ["top"]) Used
 
 mkUCall :: Count -> UseDmd -> UseDmd
 --mkUCall c Used = Used c
@@ -397,8 +403,9 @@ mkUProd ux
   | otherwise          = UProd ux
 
 lubCount :: Count -> Count -> Count
-lubCount _ Many = Many
-lubCount Many _ = Many
+lubCount (Many r1) (Many r2) = Many (r1 `lubManyReasons` r2)
+lubCount _ (Many r) = Many r
+lubCount (Many r) _ = Many r
 lubCount x _    = x
 
 lubArgUse :: ArgUse -> ArgUse -> ArgUse
@@ -426,30 +433,35 @@ lubUse Used _                      = Used  -- Note [Used should win]
 --  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).
 --  Also,  x `bothUse` x /= x (for anything but Abs).
 
-bothArgUse :: ArgUse -> ArgUse -> ArgUse
-bothArgUse Abs x                   = x
-bothArgUse x Abs                   = x
-bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)
+bothCount :: String -> Count -> Count -> Count
+bothCount r One One = Many [r]
+bothCount r One (Many mr) = Many  (mr `lubManyReasons` [r])
+bothCount r (Many mr) One = Many  (mr `lubManyReasons` [r])
+bothCount r (Many mr1) (Many mr2) = Many  (mr1 `lubManyReasons` mr2 `lubManyReasons` [r])
 
+bothArgUse :: String -> ArgUse -> ArgUse -> ArgUse
+bothArgUse _ Abs x                    = x
+bothArgUse _ x Abs                    = x
+bothArgUse r (Use c1 a1) (Use c2 a2)  = Use (bothCount r c1 c2) (bothUse r a1 a2)
 
-bothUse :: UseDmd -> UseDmd -> UseDmd
-bothUse UHead       u               = u
-bothUse (UCall c u) UHead           = UCall c u
+bothUse :: String -> UseDmd -> UseDmd -> UseDmd
+bothUse UHead       u               = u
+bothUse (UCall c u) UHead           = UCall c u
 
 -- Exciting special treatment of inner demand for call demands:
 --    use `lubUse` instead of `bothUse`!
-bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)
+bothUse r (UCall _ u1) (UCall _ u2)   = UCall (Many [r]) (u1 `lubUse` u2)
 
-bothUse (UCall {}) _                = Used
-bothUse (UProd ux) UHead            = UProd ux
-bothUse (UProd ux1) (UProd ux2)
-      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2
+bothUse (UCall {}) _                = Used
+bothUse (UProd ux) UHead            = UProd ux
+bothUse (UProd ux1) (UProd ux2)
+      | length ux1 == length ux2    = UProd $ zipWith (bothArgUse r) ux1 ux2
       | otherwise                   = Used
-bothUse (UProd {}) (UCall {})       = Used
+bothUse (UProd {}) (UCall {})       = Used
 -- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
-bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)
-bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)
-bothUse Used _                      = Used  -- Note [Used should win]
+bothUse r Used (UProd ux)             = UProd (map (\x -> bothArgUse r x useTop) ux)
+bothUse r (UProd ux) Used             = UProd (map (\x -> bothArgUse r x useTop) ux)
+bothUse Used _                      = Used  -- Note [Used should win]
 
 peelUseCall :: UseDmd -> Maybe (Count, UseDmd)
 peelUseCall (UCall c u)   = Just (c,u)
@@ -462,7 +474,7 @@ addCaseBndrDmd :: Demand    -- On the case binder
 addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds
   = case mu of
      Abs     -> alt_dmds
-     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
+     Use _ u -> zipWith (bothDmd "caseBndr") alt_dmds (mkJointDmds ss us)
              where
                 Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call
                 Just us = splitUseProdDmd      arity u   -- Ditto
@@ -548,20 +560,24 @@ Compare with: (C) making Used win for both, but UProd win for lub
 
 -- If a demand is used multiple times (i.e. reused), than any use-once
 -- mentioned there, that is not protected by a UCall, can happen many times.
-markReusedDmd :: ArgUse -> ArgUse
-markReusedDmd Abs         = Abs
-markReusedDmd (Use _ a)   = Use Many (markReused a)
+markReusedDmd :: ManyReasons -> ArgUse -> ArgUse
+markReusedDmd _ Abs         = Abs
+markReusedDmd r (Use c a)   = Use (addReason r c) (markReused r a)
+
+addReason :: ManyReasons -> Count -> Count
+addReason r One = Many r
+addReason r (Many mr) = Many (mr `lubManyReasons` r)
 
-markReused :: UseDmd -> UseDmd
-markReused (UCall _ u)      = UCall Many u   -- No need to recurse here
-markReused (UProd ux)       = UProd (map markReusedDmd ux)
-markReused u                = u
+markReused :: ManyReasons -> UseDmd -> UseDmd
+markReused r (UCall c u)      = UCall (addReason r c) u   -- No need to recurse here
+markReused r (UProd ux)       = UProd (map (markReusedDmd r) ux)
+markReused u                = u
 
 isUsedMU :: ArgUse -> Bool
 -- True <=> markReusedDmd d = d
 isUsedMU Abs          = True
 isUsedMU (Use One _)  = False
-isUsedMU (Use Many u) = isUsedU u
+isUsedMU (Use (Many _) u) = isUsedU u
 
 isUsedU :: UseDmd -> Bool
 -- True <=> markReused d = d
@@ -569,7 +585,7 @@ isUsedU Used           = True
 isUsedU UHead          = True
 isUsedU (UProd us)     = all isUsedMU us
 isUsedU (UCall One _)  = False
-isUsedU (UCall Many _) = True  -- No need to recurse
+isUsedU (UCall (Many _) _) = True  -- No need to recurse
 
 -- Squashing usage demand demands
 seqUseDmd :: UseDmd -> ()
@@ -587,7 +603,7 @@ seqArgUse _          = ()
 
 -- Splitting polymorphic Maybe-Used demands
 splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]
-splitUseProdDmd n Used        = Just (replicate n useTop)
+splitUseProdDmd n Used        = Just (replicate n (Use (Many ["splitUse"]) Used))
 splitUseProdDmd n UHead       = Just (replicate n Abs)
 splitUseProdDmd n (UProd ds)  = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds )
                                 Just ds
@@ -596,9 +612,8 @@ splitUseProdDmd _ (UCall _ _) = Nothing
       -- and we don't then want to crash the compiler (Trac #9208)
 
 useCount :: Use u -> Count
-useCount Abs         = One
-useCount (Use One _) = One
-useCount _           = Many
+useCount Abs       = One
+useCount (Use c _) = c
 
 
 {-
@@ -647,18 +662,19 @@ type CleanDemand = JointDmd StrDmd UseDmd
 
 bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
 bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})
-  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }
+  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse'` a2 }
+  where bothUse' = bothUse "bothCleanDmd"
 
 mkHeadStrict :: CleanDemand -> CleanDemand
 mkHeadStrict cd = cd { sd = HeadStr }
 
 mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand
 mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a }
-mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a }
+mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use (Many ["mkManyUsedDmd"]) a }
 
 evalDmd :: Demand
 -- Evaluated strictly, and used arbitrarily deeply
-evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }
+evalDmd = JD { sd = Str VanStr HeadStr, ud = Use (Many ["evalDmd"]) Used }
 
 mkProdDmd :: [Demand] -> CleanDemand
 mkProdDmd dx
@@ -679,7 +695,7 @@ cleanEvalDmd :: CleanDemand
 cleanEvalDmd = JD { sd = HeadStr, ud = Used }
 
 cleanEvalProdDmd :: Arity -> CleanDemand
-cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }
+cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n (Use (Many ["cleanEval"]) Used)) }
 
 
 {-
@@ -697,15 +713,16 @@ lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
  = JD { sd = s1 `lubArgStr` s2
       , ud = a1 `lubArgUse` a2 }
 
-bothDmd :: Demand -> Demand -> Demand
-bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
+bothDmd :: String -> Demand -> Demand -> Demand
+bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
  = JD { sd = s1 `bothArgStr` s2
-      , ud = a1 `bothArgUse` a2 }
+      , ud = a1 `bothArgUse'` a2 }
+  where bothArgUse' = bothArgUse r
 
 lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand
 
 strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)
-                     , ud = Use Many (UCall One Used) }
+                     , ud = Use (Many ["strictApply1Dmd"]) (UCall One Used) }
 
 -- First argument of catch#:
 --    uses its arg once, applies it once
@@ -726,7 +743,10 @@ absDmd :: Demand
 absDmd = JD { sd = Lazy, ud = Abs }
 
 topDmd :: Demand
-topDmd = JD { sd = Lazy, ud = useTop }
+topDmd = JD { sd = Lazy, ud = Use (Many ["topDmd"]) Used }
+
+boringTopDmd :: String -> Demand
+boringTopDmd r = JD { sd = Lazy, ud =  Use (Many [r]) Used }
 
 botDmd :: Demand
 botDmd = JD { sd = strBot, ud = useBot }
@@ -740,8 +760,8 @@ oneifyDmd jd                            = jd
 
 isTopDmd :: Demand -> Bool
 -- Used to suppress pretty-printing of an uninformative demand
-isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True
-isTopDmd _                                    = False
+isTopDmd (JD {sd = Lazy, ud = Use (Many _) Used}) = False -- True
+isTopDmd _                                        = False
 
 isAbsDmd :: Demand -> Bool
 isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr
@@ -754,7 +774,12 @@ isSeqDmd _                                                = False
 isUsedOnce :: Demand -> Bool
 isUsedOnce (JD { ud = a }) = case useCount a of
                                One  -> True
-                               Many -> False
+                               Many _ -> False
+
+isBoringDemand :: Demand -> ManyReasons
+isBoringDemand (JD { ud = a }) = case useCount a of
+                               One  -> []
+                               Many b -> b
 
 -- More utility functions for strictness
 seqDemand :: Demand -> ()
@@ -1033,7 +1058,7 @@ resTypeArgDmd :: Termination r -> Demand
 --      TopRes === (Top -> TopRes) === ...
 -- This function makes that concrete
 -- Also see Note [defaultDmd vs. resTypeArgDmd]
-resTypeArgDmd (Dunno _) = topDmd
+resTypeArgDmd (Dunno _) = boringTopDmd "unsat"
 resTypeArgDmd _         = botDmd   -- Diverges or ThrowsExn
 
 {-
@@ -1246,9 +1271,10 @@ bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
     -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
     -- 'both' takes the argument/result info from its *first* arg,
     -- using its second arg just for its free-var info.
-  = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))
+  = DmdType (plusVarEnv_CD bothDmd' fv1 (defaultDmd r1) fv2 (defaultDmd t2))
             ds1
             (r1 `bothDmdResult` t2)
+  where bothDmd' = bothDmd "bothDmdType"
 
 instance Outputable DmdType where
   ppr (DmdType fv ds res)
@@ -1401,9 +1427,9 @@ postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env
   -- We only processed the thing at all to analyse the body
   -- See Note [Always analyse in virgin pass]
 
-reuseEnv :: DmdEnv -> DmdEnv
-reuseEnv = mapVarEnv (postProcessDmd
-                        (JD { sd = Str VanStr (), ud = Use Many () }))
+reuseEnv :: String -> DmdEnv -> DmdEnv
+reuseEnv = mapVarEnv (postProcessDmd
+                        (JD { sd = Str VanStr (), ud = Use (Many [r]) () }))
 
 postProcessUnsat :: DmdShell -> DmdType -> DmdType
 postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)
@@ -1420,9 +1446,9 @@ postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})
            Str ExnStr _ -> markExnStr s
            Str VanStr _ -> s
     a' = case us of
-           Abs        -> Abs
-           Use Many _ -> markReusedDmd a
-           Use One  _ -> a
+           Abs            -> Abs
+           Use (Many r) _ -> markReusedDmd r a
+           Use One  _     -> a
 
 markExnStr :: ArgStr -> ArgStr
 markExnStr (Str VanStr s) = Str ExnStr s
@@ -1442,8 +1468,8 @@ peelCallDmd (JD {sd = s, ud = u})
                  HyperStr -> (HyperStr, Str VanStr ())
                  _        -> (HeadStr,  Lazy)
     (u', us) = case u of
-                 UCall c u' -> (u',   Use c    ())
-                 _          -> (Used, Use Many ())
+                 UCall c u' -> (u',   Use c            ())
+                 _          -> (Used, Use (Many ["peel"]) ())
        -- The _ cases for usage includes UHead which seems a bit wrong
        -- because the body isn't used at all!
        -- c.f. the Abs case in toCleanDmd
@@ -1464,7 +1490,7 @@ peelManyCalls n (JD { sd = str, ud = abs })
     go_abs :: Int -> UseDmd -> Use ()      -- Many <=> unsaturated, or at least
     go_abs 0 _              = Use One ()   --          one UCall Many in the demand
     go_abs n (UCall One d') = go_abs (n-1) d'
-    go_abs _ _              = Use Many ()
+    go_abs _ _              = Use (Many ["peel"]) ()
 
 {-
 Note [Demands from unsaturated function calls]
@@ -1816,8 +1842,8 @@ argOneShots one_shot_info (JD { ud = usg })
       Use _ arg_usg -> go arg_usg
       _             -> []
   where
-    go (UCall One  u) = one_shot_info : go u
-    go (UCall Many u) = NoOneShotInfo : go u
+    go (UCall One      u) = one_shot_info : go u
+    go (UCall (Many _) u) = NoOneShotInfo : go u
     go _              = []
 
 {- Note [Computing one-shot info, and ProbOneShot]
@@ -1932,15 +1958,15 @@ kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}
 
 zap_musg :: KillFlags -> ArgUse -> ArgUse
 zap_musg kfs Abs
-  | kf_abs kfs = useTop
+  | kf_abs kfs = Use (Many ["zap"]) Used
   | otherwise  = Abs
 zap_musg kfs (Use c u)
-  | kf_used_once kfs = Use Many (zap_usg kfs u)
-  | otherwise        = Use c    (zap_usg kfs u)
+  | kf_used_once kfs = Use (Many ["zap"]) (zap_usg kfs u)
+  | otherwise        = Use c              (zap_usg kfs u)
 
 zap_usg :: KillFlags -> UseDmd -> UseDmd
 zap_usg kfs (UCall c u)
-    | kf_called_once kfs = UCall Many (zap_usg kfs u)
+    | kf_called_once kfs = UCall (Many ["zap"]) (zap_usg kfs u)
     | otherwise          = UCall c    (zap_usg kfs u)
 zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)
 zap_usg _   u            = u
@@ -1956,7 +1982,7 @@ strictifyDictDmd ty dmd = case getUseDmd dmd of
     Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)
       <- splitDataProductType_maybe ty,
     not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary
-    -> seqDmd `bothDmd` -- main idea: ensure it's strict
+    -> bothDmd "strictify" seqDmd $
        case splitProdDmd_maybe dmd of
          -- superclass cycles should not be a problem, since the demand we are
          -- consuming would also have to be infinite in order for us to diverge
@@ -2040,12 +2066,15 @@ instance Binary ArgStr where
 
 instance Binary Count where
     put_ bh One  = do putByte bh 0
-    put_ bh Many = do putByte bh 1
+    put_ bh (Many mr) = do
+        putByte bh 1
+        put_ bh (map mkFastString mr)
 
     get  bh = do h <- getByte bh
                  case h of
                    0 -> return One
-                   _ -> return Many
+                   _ -> do mr <- get bh
+                           return (Many (map unpackFS mr))
 
 instance Binary ArgUse where
     put_ bh Abs          = do
index 97d4186..1f99f4a 100644 (file)
@@ -270,7 +270,7 @@ vanillaIdInfo
             oneShotInfo         = NoOneShotInfo,
             inlinePragInfo      = defaultInlinePragma,
             occInfo             = NoOccInfo,
-            demandInfo          = topDmd,
+            demandInfo          = boringTopDmd "vanilla",
             strictnessInfo      = nopSig,
             callArityInfo     = unknownArity
            }
@@ -453,7 +453,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
   | is_safe_occ occ && is_safe_dmd demand
   = Nothing
   | otherwise
-  = Just (info {occInfo = safe_occ, demandInfo = topDmd})
+  = Just (info {occInfo = safe_occ, demandInfo = boringTopDmd "zap"})
   where
         -- The "unsafe" occ info is the ones that say I'm not in a lambda
         -- because that might not be true for an unsaturated lambda
@@ -468,7 +468,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
 
 -- | Remove all demand info on the 'IdInfo'
 zapDemandInfo :: IdInfo -> Maybe IdInfo
-zapDemandInfo info = Just (info {demandInfo = topDmd})
+zapDemandInfo info = Just (info {demandInfo = boringTopDmd "zap"})
 
 -- | Remove usage (but not strictness) info on the 'IdInfo'
 zapUsageInfo :: IdInfo -> Maybe IdInfo
index e146c66..d277b8b 100644 (file)
@@ -381,7 +381,7 @@ mkDataConWorkId wkr_name data_con
                 `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                      -- even if arity = 0
 
-    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
+    wkr_sig = mkClosedStrictSig (replicate wkr_arity (boringTopDmd "dcon")) (dataConCPR data_con)
         --      Note [Data-con worker strictness]
         -- Notice that we do *not* say the worker is strict
         -- even if the data constructor is declared strict
@@ -493,7 +493,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
              wrap_arg_dmds = map mk_dmd arg_ibangs
              mk_dmd str | isBanged str = evalDmd
-                        | otherwise           = topDmd
+                        | otherwise    = boringTopDmd "dcon"
                  -- The Cpr info can be important inside INLINE rhss, where the
                  -- wrapper constructor isn't inlined.
                  -- And the argument strictness can be important too; we
@@ -971,7 +971,7 @@ mkFCallId dflags uniq fcall ty
 
     (bndrs, _) = tcSplitPiTys ty
     arity      = count isAnonTyBinder bndrs
-    strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
+    strict_sig = mkClosedStrictSig (replicate arity (boringTopDmd "foreign")) topRes
     -- the call does not claim to be strict in its arguments, since they
     -- may be lifted (foreign import prim) and the called code doesn't
     -- necessarily force them. See Trac #11076.
index df00203..83edc8d 100644 (file)
@@ -56,6 +56,7 @@ module CLabel (
         mkDirty_MUT_VAR_Label,
         mkUpdInfoLabel,
         mkBHUpdInfoLabel,
+        mkCountingIndInfoLabel,
         mkIndStaticInfoLabel,
         mkMainCapabilityLabel,
         mkMAP_FROZEN_infoLabel,
@@ -418,7 +419,8 @@ mkStaticConEntryLabel name  c     = IdLabel name c StaticConEntry
 
 -- Constructing Cmm Labels
 mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
-    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkCountingIndInfoLabel,
+    mkMainCapabilityLabel,
     mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel,
     mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
     mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
@@ -428,6 +430,7 @@ mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing
 mkSplitMarkerLabel              = CmmLabel rtsUnitId (fsLit "__stg_split_marker")    CmmCode
 mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
+mkCountingIndInfoLabel          = CmmLabel rtsUnitId (fsLit "stg_COUNTING_IND")      CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
 mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData
 mkMAP_FROZEN_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo
index 4abbeaf..c02471c 100644 (file)
@@ -17,6 +17,7 @@ module CmmType
     , rEP_CostCentreStack_scc_count
     , rEP_StgEntCounter_allocs
     , rEP_StgEntCounter_allocd
+    , rEP_StgEntCounter_allocd_count
 
     , ForeignHint(..)
 
@@ -352,6 +353,11 @@ rEP_StgEntCounter_allocd dflags
     = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))
     where pc = sPlatformConstants (settings dflags)
 
+rEP_StgEntCounter_allocd_count :: DynFlags -> CmmType
+rEP_StgEntCounter_allocd_count dflags
+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd_count pc))
+    where pc = sPlatformConstants (settings dflags)
+
 -------------------------------------------------------------------------
 {-      Note [Signed vs unsigned]
         ~~~~~~~~~~~~~~~~~~~~~~~~~
index ecd8905..6710e83 100644 (file)
@@ -22,7 +22,7 @@ module SMRep (
         ConstrDescription,
 
         -- ** Construction
-        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
+        mkHeapRep, blackHoleRep, indStaticRep, countingIndRep, mkStackRep, mkRTSRep, arrPtrsRep,
         smallArrPtrsRep, arrWordsRep,
 
         -- ** Predicates
@@ -189,6 +189,7 @@ data ClosureTypeInfo
   | Thunk
   | ThunkSelector SelectorOffset
   | BlackHole
+  | CountingInd
   | IndStatic
 
 type ConstrTag         = Int
@@ -249,6 +250,10 @@ blackHoleRep = HeapRep False 0 0 BlackHole
 indStaticRep :: SMRep
 indStaticRep = HeapRep True 1 0 IndStatic
 
+countingIndRep :: SMRep
+countingIndRep = HeapRep False 1 2 CountingInd
+
+
 arrPtrsRep :: DynFlags -> WordOff -> SMRep
 arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
 
@@ -279,6 +284,7 @@ isThunkRep :: SMRep -> Bool
 isThunkRep (HeapRep _ _ _ Thunk{})         = True
 isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
 isThunkRep (HeapRep _ _ _ BlackHole{})     = True
+isThunkRep (HeapRep _ _ _ CountingInd{})       = True
 isThunkRep (HeapRep _ _ _ IndStatic{})     = True
 isThunkRep _                               = False
 
@@ -386,6 +392,7 @@ closureTypeHdrSize dflags ty = case ty of
                   Thunk{}         -> thunkHdrSize dflags
                   ThunkSelector{} -> thunkHdrSize dflags
                   BlackHole{}     -> thunkHdrSize dflags
+                  CountingInd{}     -> thunkHdrSize dflags
                   IndStatic{}     -> thunkHdrSize dflags
                   _               -> fixedHdrSizeW dflags
         -- All thunks use thunkHdrSize, even if they are non-updatable.
@@ -459,6 +466,7 @@ rtsClosureType rep
       HeapRep True _ _ Thunk{}  -> THUNK_STATIC
 
       HeapRep False _ _ BlackHole{} -> BLACKHOLE
+      HeapRep False _ _ CountingInd{} -> COUNTING_IND
 
       HeapRep False _ _ IndStatic{} -> IND_STATIC
 
@@ -535,6 +543,7 @@ pprTypeInfo (ThunkSelector offset)
 
 pprTypeInfo Thunk     = text "Thunk"
 pprTypeInfo BlackHole = text "BlackHole"
+pprTypeInfo CountingInd   = text "CountingInd"
 pprTypeInfo IndStatic = text "IndStatic"
 
 -- XXX Does not belong here!!
index 8adf3b0..492190b 100644 (file)
@@ -46,6 +46,7 @@ import Module
 import ListSetOps
 import Util
 import BasicTypes
+import TyCon ( PrimRep )
 import Outputable
 import FastString
 import DynFlags
@@ -112,11 +113,12 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
                  -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
         ; emitDataLits closure_label closure_rep
         ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
-              (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                               (addIdReps [])
+              (_, _, fv_details, []) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
+                                               (addIdReps []) 0
         -- Don't drop the non-void args until the closure info has been made
-        ; forkClosureBody (closureCodeBody True id closure_info ccs
-                                (nonVoidIds args) (length args) body fv_details)
+        ; forkClosureBody $
+            closureCodeBody True id closure_info ccs (nonVoidIds args)
+                            (length args) body fv_details Nothing
 
         ; return () }
 
@@ -289,7 +291,7 @@ mkRhsClosure    dflags bndr _cc _bi
     -- will evaluate to.
     --
     -- srt is discarded; it must be empty
-    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) (isBoring upd_flag)
     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
 
 ---------- Note [Ap thunks] ------------------
@@ -325,7 +327,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; return (id_info, gen_code lf_info reg) }
  where
  gen_code lf_info reg
-  = do  {       -- LAY OUT THE OBJECT
+  = do  { dflags <- getDynFlags
+
+        -- LAY OUT THE OBJECT
         -- If the binder is itself a free variable, then don't store
         -- it in the closure.  Instead, just bind it to Node on entry.
         -- NB we can be sure that Node will point to it, because we
@@ -339,16 +343,27 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
                 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
                             | otherwise    = fvs
 
+        ; let count_entries_in_code =
+                gopt Opt_Ticky_Dyn_Thunk dflags && not (null args)
+        ; let count_entry_with_wrapper =
+                gopt Opt_Ticky_Dyn_Thunk dflags && null args
 
         -- MAKE CLOSURE INFO FOR THIS CLOSURE
         ; mod_name <- getModuleName
-        ; dflags <- getDynFlags
         ; let   name  = idName bndr
                 descr = closureDescription dflags mod_name name
+                fv_reps :: [(PrimRep, Id)]
+                fv_reps = addIdReps (map unsafe_stripNV reduced_fvs)
+
                 fv_details :: [(NonVoid Id, ByteOff)]
-                (tot_wds, ptr_wds, fv_details)
-                   = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                       (addIdReps (map unsafe_stripNV reduced_fvs))
+                (tot_wds, ptr_wds, fv_details, extra_word_offs)
+                   = mkVirtHeapOffsets dflags (isLFThunk lf_info) fv_reps 1
+
+                entry_ctr_offM
+                    | count_entries_in_code   = Just entry_ctr_off
+                    | otherwise = Nothing
+                        where [entry_ctr_off] = extra_word_offs
+
                 closure_info = mkClosureInfo dflags False       -- Not static
                                              bndr lf_info tot_wds ptr_wds
                                              descr
@@ -359,7 +374,7 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
                 --                  (b) ignore Sequel from context; use empty Sequel
                 -- And compile the body
                 closureCodeBody False bndr closure_info cc (nonVoidIds args)
-                                (length args) body fv_details
+                                (length args) body fv_details entry_ctr_offM
 
         -- BUILD THE OBJECT
 --      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
@@ -370,8 +385,18 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
                                          (map toVarArg fv_details)
 
+        ; -- Initialize dynamic entry counter to zero (where to do this properly?)
+        ; forM_ entry_ctr_offM $ \entry_ctr_off ->
+            emit (mkStore (cmmOffset dflags hp_plus_n entry_ctr_off) (zeroExpr dflags))
+
+        -- WRAP IT IN A COUNTING_IND
+        -- first and third arguments are only used for tickyDynAlloc
+        ; hp_plus_m <- if count_entry_with_wrapper
+                       then wrapInCountingInd dflags bndr use_cc hp_plus_n
+                       else return hp_plus_n
+
         -- RETURN
-        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+        ; return (mkRhsInit dflags reg lf_info hp_plus_m) }
 
 -------------------------
 cgRhsStdThunk
@@ -386,13 +411,16 @@ cgRhsStdThunk bndr lf_info payload
        }
  where
  gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
+  = withNewTickyCounterStdThunk
+        (lfUpdatable lf_info)
+        (lfBoring lf_info)
+        (idName bndr) $
     do
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
-  ; let (tot_wds, ptr_wds, payload_w_offsets)
-            = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
+  ; let (tot_wds, ptr_wds, payload_w_offsets, [])
+            = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) 0
 
         descr = closureDescription dflags mod_name (idName bndr)
         closure_info = mkClosureInfo dflags False       -- Not static
@@ -402,14 +430,21 @@ cgRhsStdThunk bndr lf_info payload
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
   ; let use_cc = curCCS; blame_cc = curCCS
 
-
         -- BUILD THE OBJECT
   ; let info_tbl = mkCmmInfo closure_info
   ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
+  -- WRAP IT IN A COUNTING_IND
+  -- first and third arguments are only used for tickyDynAlloc
+  ; let count_entry_with_wrapper = gopt Opt_Ticky_Dyn_Thunk dflags
+
+  ; hp_plus_m <- if count_entry_with_wrapper
+                 then wrapInCountingInd dflags bndr use_cc hp_plus_n
+                 else return hp_plus_n
+
         -- RETURN
-  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+  ; return (mkRhsInit dflags reg lf_info hp_plus_m) }
 
 
 mkClosureLFInfo :: DynFlags
@@ -438,6 +473,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
                 -> Int             -- arity, including void args
                 -> StgExpr
                 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
+                -> Maybe ByteOff       -- Offset of the dynamic entry ticky counter
                 -> FCode ()
 
 {- There are two main cases for the code for closures.
@@ -450,11 +486,12 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
   normal form, so there is no need to set up an update frame.
 -}
 
-closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
+closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details _entry_ctr_off
   | arity == 0 -- No args i.e. thunk
   = withNewTickyCounterThunk
         (isStaticClosure cl_info)
         (closureUpdReqd cl_info)
+        (closureBoring cl_info)
         (closureName cl_info) $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
@@ -462,7 +499,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
      lf_info  = closureLFInfo cl_info
      info_tbl = mkCmmInfo cl_info
 
-closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details entry_ctr_offM
   = -- Note: args may be [], if all args are Void
     withNewTickyCounterFun
         (closureSingleEntry cl_info)
@@ -491,8 +528,15 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                 ; entryHeapCheck cl_info node' arity arg_regs $ do
                 { -- emit LDV code when profiling
                   when node_points (ldvEnterClosure cl_info (CmmLocal node))
+
                 -- ticky after heap check to avoid double counting
-                ; tickyEnterFun cl_info
+                ; let tag = lfDynTag dflags lf_info
+                ; let entry_ctr_expM = case entry_ctr_offM of
+                        { Just entry_ctr_off -> Just $ mkTaggedObjectExpr dflags node entry_ctr_off tag
+                        ; Nothing -> Nothing
+                        }
+                ; tickyEnterFun cl_info entry_ctr_expM
+
                 ; enterCostCentreFun cc
                     (CmmMachOp (mo_wordSub dflags)
                          [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
@@ -569,9 +613,13 @@ thunkCode cl_info fv_details _cc node arity body
 
         -- Heap overflow check
         ; entryHeapCheck cl_info node' arity [] $ do
-        { -- Overwrite with black hole if necessary
+        {
+         -- Disabled for now, as we (temporarily unconditionally) move the
+         -- counting to the counting indirection
+         -- tickyEnterThunk cl_info
+
+          -- Overwrite with black hole if necessary
           -- but *after* the heap-overflow check
-        ; tickyEnterThunk cl_info
         ; when (blackHoleOnEntry cl_info && node_points)
                 (blackHoleIt node)
 
index c612366..7d28422 100644 (file)
@@ -24,7 +24,7 @@ module StgCmmClosure (
         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
         lfDynTag,
-        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
+        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, lfBoring,
 
         -- * Used by other modules
         CgLoc(..), SelfLoopInfo, CallMethod(..),
@@ -45,7 +45,7 @@ module StgCmmClosure (
 
         -- ** Predicates
         -- These are really just functions on LambdaFormInfo
-        closureUpdReqd, closureSingleEntry,
+        closureUpdReqd, closureBoring, closureSingleEntry,
         closureReEntrant, closureFunInfo,
         isToplevClosure,
 
@@ -55,6 +55,7 @@ module StgCmmClosure (
         -- * InfoTables
         mkDataConInfoTable,
         cafBlackHoleInfoTable,
+        countingIndInfoTable,
         indStaticInfoTable,
         staticClosureNeedsLink,
     ) where
@@ -156,6 +157,7 @@ data LambdaFormInfo
         TopLevelFlag
         !Bool           -- True <=> no free vars
         !Bool           -- True <=> updatable (i.e., *not* single-entry)
+        [String]        -- [] <=> boring
         StandardFormInfo
         !Bool           -- True <=> *might* be a function type
 
@@ -240,6 +242,7 @@ mkLFThunk thunk_ty top fvs upd_flag
   = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
     LFThunk top (null fvs)
             (isUpdatable upd_flag)
+            (isBoring upd_flag)
             NonStandardThunk
             (might_be_a_function thunk_ty)
 
@@ -260,15 +263,15 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
 mkConLFInfo con = LFCon con
 
 -------------
-mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
-mkSelectorLFInfo id offset updatable
-  = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+mkSelectorLFInfo :: Id -> Int -> Bool -> [String] -> LambdaFormInfo
+mkSelectorLFInfo id offset updatable boring
+  = LFThunk NotTopLevel False updatable boring (SelectorThunk offset)
         (might_be_a_function (idType id))
 
 -------------
 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (isBoring upd_flag) (ApThunk arity)
         (might_be_a_function (idType id))
 
 -------------
@@ -365,7 +368,7 @@ lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
 lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
 lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
                                                     (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
+lfClosureType (LFThunk _ _ _ _ is_sel _)     = thunkClosureType is_sel
 lfClosureType _                              = panic "lfClosureType"
 
 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
@@ -393,7 +396,7 @@ nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
         -- non-inherited (i.e. non-top-level) function.
         -- The isNotTopLevel test above ensures this is ok.
 
-nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
+nodeMustPointToIt dflags (LFThunk top no_fvs updatable _boring NonStandardThunk _)
   =  not no_fvs            -- Self parameter
   || isNotTopLevel top     -- Note [GC recovery]
   || updatable             -- Need to push update frame
@@ -536,7 +539,7 @@ getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
     -- n_args=0 because it'd be ill-typed to apply a saturated
     --          constructor application to anything
 
-getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
               n_args _v_args _cg_loc _self_loop_info
   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
@@ -767,7 +770,7 @@ blackHoleOnEntry cl_info
   = case closureLFInfo cl_info of
       LFReEntrant {}            -> False
       LFLetNoEscape             -> False
-      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
       _other -> panic "blackHoleOnEntry"
 
 {- Note [Black-holing non-updatable thunks]
@@ -843,12 +846,19 @@ isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 closureUpdReqd :: ClosureInfo -> Bool
 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
 
+closureBoring :: ClosureInfo -> [String]
+closureBoring ClosureInfo{ closureLFInfo = lf_info } = lfBoring lf_info
+
 lfUpdatable :: LambdaFormInfo -> Bool
-lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable (LFThunk _ _ upd _ _ _)  = upd
 lfUpdatable _ = False
 
+lfBoring :: LambdaFormInfo -> [String]
+lfBoring (LFThunk _ _ _ bor _ _)  = bor
+lfBoring _ = []
+
 closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ _}) = not upd
 closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
 closureSingleEntry _ = False
 
@@ -871,7 +881,7 @@ isToplevClosure :: ClosureInfo -> Bool
 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
   = case lf_info of
       LFReEntrant TopLevel _ _ _ _ -> True
-      LFThunk TopLevel _ _ _ _     -> True
+      LFThunk TopLevel _ _ _ _ _   -> True
       _other                       -> False
 
 --------------------------------------
@@ -892,10 +902,10 @@ closureLocalEntryLabel dflags
 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
 mkClosureInfoTableLabel id lf_info
   = case lf_info of
-        LFThunk _ _ upd_flag (SelectorThunk offset) _
+        LFThunk _ _ upd_flag (SelectorThunk offset) _
                       -> mkSelectorInfoLabel upd_flag offset
 
-        LFThunk _ _ upd_flag (ApThunk arity) _
+        LFThunk _ _ upd_flag (ApThunk arity) _
                       -> mkApInfoTableLabel upd_flag arity
 
         LFThunk{}     -> std_mk_lbl name cafs
@@ -1029,6 +1039,13 @@ indStaticInfoTable
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
+countingIndInfoTable :: CmmInfoTable
+countingIndInfoTable
+  = CmmInfoTable { cit_lbl  = mkCountingIndInfoLabel
+                 , cit_rep  = countingIndRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = NoC_SRT }
+
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
 -- the static closure graph.  But it only needs such a field if either
index ebff440..98c8c58 100644 (file)
@@ -19,7 +19,9 @@ module StgCmmHeap (
         mkStaticClosureFields, mkStaticClosure,
 
         allocDynClosure, allocDynClosureCmm, allocHeapClosure,
-        emitSetDynHdr
+        emitSetDynHdr,
+
+        wrapInCountingInd
     ) where
 
 #include "HsVersions.h"
@@ -42,7 +44,7 @@ import Cmm
 import CmmUtils
 import CostCentre
 import IdInfo( CafInfo(..), mayHaveCafRefs )
-import Id ( Id )
+import Id ( Id, idName )
 import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
@@ -65,7 +67,7 @@ allocDynClosure
         -> CmmExpr              -- Cost Centre to blame for this alloc
                                 -- (usually the same; sometimes "OVERHEAD")
 
-        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
+        -> [(NonVoid StgArg, ByteOff)]  -- Offsets from start of object
                                                 -- ie Info ptr has offset zero.
                                                 -- No void args in here
         -> FCode CmmExpr -- returns Hp+n
@@ -108,6 +110,18 @@ allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
   allocHeapClosure rep info_ptr use_cc amodes_w_offsets
 
 
+wrapInCountingInd :: DynFlags -> Id -> CmmExpr -> CmmExpr -> FCode CmmExpr
+wrapInCountingInd dflags id use_cc arg
+    = -- pprTrace "wrapInCountingInd" (ppr id <+> ppIdInfo id (idInfo id) <+> ppr (idRepArity id)) $
+      allocHeapClosure countingIndRep (CmmLit (CmmLabel mkCountingIndInfoLabel)) use_cc $
+            [ (arg,               hdr_size + oFFSET_StgCountingInd_indirectee dflags)
+            , (mkLblExpr ctr_lbl, hdr_size + oFFSET_StgCountingInd_ent_counter dflags)
+            , (zeroExpr dflags,   hdr_size + oFFSET_StgCountingInd_entries dflags)
+            ]
+  where
+    ctr_lbl = mkRednCountsLabel (idName id)
+    hdr_size = fixedHdrSize dflags
+
 -- | Low-level heap object allocation.
 allocHeapClosure
   :: SMRep                            -- ^ representation of the object
index 47ee370..5dcf535 100644 (file)
@@ -388,11 +388,13 @@ getHpRelOffset virtual_offset
 
 mkVirtHeapOffsets
   :: DynFlags
-  -> Bool                -- True <=> is a thunk
-  -> [(PrimRep,a)]        -- Things to make offsets for
+  -> Bool                     -- True <=> is a thunk
+  -> [(PrimRep,a)]            -- Things to make offsets for
+  -> Int                      -- Extra words to include
   -> (WordOff,                -- _Total_ number of words allocated
       WordOff,                -- Number of words allocated for *pointers*
-      [(NonVoid a, ByteOff)])
+      [(NonVoid a, ByteOff)], -- Offsets for things
+      [ByteOff])              -- Offsets for extra words
 
 -- Things with their offsets from start of object in order of
 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
@@ -404,10 +406,11 @@ mkVirtHeapOffsets
 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
 -- than the unboxed things
 
-mkVirtHeapOffsets dflags is_thunk things
+mkVirtHeapOffsets dflags is_thunk things extra_words
   = ( bytesToWordsRoundUp dflags tot_bytes
     , bytesToWordsRoundUp dflags bytes_of_ptrs
     , ptrs_w_offsets ++ non_ptrs_w_offsets
+    , extra_w_offsets
     )
   where
     hdr_words | is_thunk   = thunkHdrSize dflags
@@ -419,18 +422,26 @@ mkVirtHeapOffsets dflags is_thunk things
 
     (bytes_of_ptrs, ptrs_w_offsets) =
        mapAccumL computeOffset 0 ptrs
-    (tot_bytes, non_ptrs_w_offsets) =
+    (bytes_of_ptrs_non_ptrs, non_ptrs_w_offsets) =
        mapAccumL computeOffset bytes_of_ptrs non_ptrs
+    (tot_bytes, extra_w_offsets) =
+       mapAccumL computeOffset' bytes_of_ptrs_non_ptrs [1..extra_words]
 
     computeOffset bytes_so_far (rep, thing)
       = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),
          (NonVoid thing, hdr_bytes + bytes_so_far))
 
+    computeOffset' bytes_so_far _
+      = (bytes_so_far + wordsToBytes dflags 1,
+         (hdr_bytes + bytes_so_far))
+
 -- | Just like mkVirtHeapOffsets, but for constructors
 mkVirtConstrOffsets
   :: DynFlags -> [(PrimRep,a)]
   -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
+mkVirtConstrOffsets dflags things =
+    let (tot_rds, ptr_wds, payload_w_offsets, []) = mkVirtHeapOffsets dflags False things 0
+    in  (tot_rds, ptr_wds, payload_w_offsets)
 
 
 -------------------------------------------------------------------------
index 8df2dca..3d3ea4a 100644 (file)
@@ -137,6 +137,7 @@ import TyCon
 import Data.Maybe
 import qualified Data.Char
 import Control.Monad ( unless, when )
+import Data.Foldable ( forM_ )
 
 -----------------------------------------------------------------------------
 --
@@ -150,6 +151,7 @@ data TickyClosureType
     | TickyCon
     | TickyThunk
         Bool -- True <-> updateable
+        [String] -- Why updateable?
         Bool -- True <-> standard thunk (AP or selector), has no entry counter
     | TickyLNE
 
@@ -164,25 +166,27 @@ withNewTickyCounterLNE nm args code = do
 withNewTickyCounterThunk
   :: Bool -- ^ static
   -> Bool -- ^ updateable
+  -> [String] -- ^ manyReasons
   -> Name
   -> FCode a
   -> FCode a
-withNewTickyCounterThunk isStatic isUpdatable name code = do
+withNewTickyCounterThunk isStatic isUpdatable isBoring name code = do
     b <- tickyDynThunkIsOn
     if isStatic || not b -- ignore static thunks
       then code
-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable isBoring False) name [] code
 
 withNewTickyCounterStdThunk
   :: Bool -- ^ updateable
+  -> [String] -- ^ manyReasons
   -> Name
   -> FCode a
   -> FCode a
-withNewTickyCounterStdThunk isUpdatable name code = do
+withNewTickyCounterStdThunk isUpdatable isBoring name code = do
     b <- tickyDynThunkIsOn
     if not b
       then code
-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable isBoring True) name [] code
 
 withNewTickyCounterCon
   :: Name
@@ -218,10 +222,14 @@ emitTickyCounter cloType name args
                 let n = ppr name
                     ext = case cloType of
                               TickyFun single_entry -> parens $ hcat $ punctuate comma $
-                                  [text "fun"] ++ [text "se"|single_entry]
+                                  [text "fun"] ++
+                                  [text "se"|single_entry]
                               TickyCon -> parens (text "con")
-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $
-                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
+                              TickyThunk upd mr std -> parens $ hcat $ punctuate comma $
+                                  [text "thk"] ++
+                                  [text "se"|not upd] ++
+                                  (if null mr then [] else [ parens $ hcat $ punctuate comma $ map text mr]) ++
+                                  [text "std"|std]
                               TickyLNE | isInternalName name -> parens (text "LNE")
                                        | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
                     p = case hasHaskellName parent of
@@ -243,11 +251,14 @@ emitTickyCounter cloType name args
         -- properly and it led to chaos, panic and disorder.
             [ mkIntCLit dflags 0,               -- registered?
               mkIntCLit dflags (length args),   -- Arity
+              mkIntCLit dflags 0,               -- Allocation count for this thing
               mkIntCLit dflags 0,               -- Heap allocated for this thing
               fun_descr_lit,
               arg_descr_lit,
-              zeroCLit dflags,          -- Entries into this thing
-              zeroCLit dflags,          -- Heap allocated by this thing
+              zeroCLit dflags,          -- entry_count
+              zeroCLit dflags,          -- single_entry_count
+              zeroCLit dflags,          -- multi_entry_count
+              zeroCLit dflags,          -- allocs
               zeroCLit dflags                   -- Link to next StgEntCounter
             ]
         }
@@ -307,8 +318,8 @@ tickyUpdateBhCaf cl_info
     ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
         | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
 
-tickyEnterFun :: ClosureInfo -> FCode ()
-tickyEnterFun cl_info = ifTicky $ do
+tickyEnterFun :: ClosureInfo -> Maybe CmmExpr -> FCode ()
+tickyEnterFun cl_info entry_ctr_expM = ifTicky $ do
   ctr_lbl <- getTickyCtrLabel
 
   if isStaticClosure cl_info
@@ -319,6 +330,30 @@ tickyEnterFun cl_info = ifTicky $ do
 
   bumpTickyEntryCount ctr_lbl
 
+  emitComment $ mkFastString "Foo"
+  forM_ entry_ctr_expM $ \entry_ctr_exp -> do
+      dflags <- getDynFlags
+      emitComment $ mkFastString "Dynamic entry counting code"
+
+      -- This code replicates the code of COUNTING_IND in StgMiscClosures.cmm. How
+      -- to de-duplicate that?
+      let test0 = cmmEqWord dflags (CmmLoad entry_ctr_exp (bWord dflags))
+                                   (zeroExpr dflags)
+          tick0 = catAGraphs $
+            [ addToMem (bWord dflags) (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_single_entry_count dflags))) 1
+            ]
+          test1 = cmmEqWord dflags (CmmLoad entry_ctr_exp (bWord dflags))
+                                   (mkIntExpr dflags 1)
+          tick1 = catAGraphs $
+            [ addToMem (bWord dflags) (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_single_entry_count dflags))) (-1)
+            , addToMem (bWord dflags) (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_multi_entry_count dflags))) 1
+            ]
+      emit =<< mkCmmIfThen test0 tick0
+      emit =<< mkCmmIfThen test1 tick1
+      emit (addToMem (bWord dflags) entry_ctr_exp 1)
+
+
+
 tickyEnterLNE :: FCode ()
 tickyEnterLNE = ifTicky $ do
   bumpTickyCounter (fsLit "ENT_LNE_ctr")
@@ -585,6 +620,7 @@ bumpTickyEntryCount lbl = do
 bumpTickyAllocd :: CLabel -> Int -> FCode ()
 bumpTickyAllocd lbl bytes = do
   dflags <- getDynFlags
+  bumpTickyLit   (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd_count dflags))
   bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
 
 bumpTickyLbl :: CLabel -> FCode ()
index 86c03ac..a490f8f 100644 (file)
@@ -19,7 +19,7 @@ module StgCmmUtils (
 
         emitMultiAssign, emitCmmLitSwitch, emitSwitch,
 
-        tagToClosure, mkTaggedObjectLoad,
+        tagToClosure, mkTaggedObjectExpr, mkTaggedObjectLoad,
 
         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
 
@@ -137,6 +137,11 @@ addToMemE rep ptr n
 --
 -------------------------------------------------------------------------
 
+mkTaggedObjectExpr
+  :: DynFlags -> LocalReg -> ByteOff -> DynTag -> CmmExpr
+mkTaggedObjectExpr dflags base offset tag
+  = cmmOffsetB dflags (CmmReg (CmmLocal base)) (offset - tag)
+
 mkTaggedObjectLoad
   :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
 -- (loadTaggedObjectField reg base off tag) generates assignment
@@ -144,10 +149,7 @@ mkTaggedObjectLoad
 -- where K is fixed by 'reg'
 mkTaggedObjectLoad dflags reg base offset tag
   = mkAssign (CmmLocal reg)
-             (CmmLoad (cmmOffsetB dflags
-                                  (CmmReg (CmmLocal base))
-                                  (offset - tag))
-                      (localRegType reg))
+             (CmmLoad (mkTaggedObjectExpr dflags base offset tag) (localRegType reg))
 
 -------------------------------------------------------------------------
 --
index ef87656..ca2001f 100644 (file)
@@ -141,7 +141,7 @@ exprBotStrictness_maybe e
         Just ar -> Just (ar, sig ar)
   where
     env    = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
-    sig ar = mkClosedStrictSig (replicate ar topDmd) exnRes
+    sig ar = mkClosedStrictSig (replicate ar (boringTopDmd "exprBotStrictness")) exnRes
                   -- For this purpose we can be very simple
                   -- exnRes is a bit less aggressive than botRes
 
index 320a989..700de62 100644 (file)
@@ -392,7 +392,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
 cpeBind top_lvl env (Rec pairs)
   = do { let (bndrs,rhss) = unzip pairs
        ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs)
-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss
+       ; stuff <- zipWithM (cpePair top_lvl Recursive (boringTopDmd "cpe") False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
              all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
@@ -424,7 +424,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
                else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
                                -- Note [Silly extra arguments]
                     (do { v <- newVar (idType bndr)
-                        ; let float = mkFloat topDmd False v rhs2
+                        ; let float = mkFloat (boringTopDmd "cpe") False v rhs2
                         ; return ( addFloat floats2 float
                                  , cpeEtaExpand arity (Var v)) })
 
@@ -713,9 +713,9 @@ cpeApp env expr
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
            ; let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId
                     = case (ss, isLazyExpr arg) of
-                        (_   : ss_rest, True)  -> (topDmd, ss_rest)
+                        (_   : ss_rest, True)  -> ((boringTopDmd "cpe"), ss_rest)
                         (ss1 : ss_rest, False) -> (ss1,    ss_rest)
-                        ([],            _)     -> (topDmd, [])
+                        ([],            _)     -> ((boringTopDmd "cpe"), [])
                  (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
                                     splitFunTy_maybe fun_ty
 
index 75e91a4..4ea2934 100644 (file)
@@ -11,7 +11,7 @@ module PprCore (
         pprCoreExpr, pprParendExpr,
         pprCoreBinding, pprCoreBindings, pprCoreAlt,
         pprCoreBindingWithSize, pprCoreBindingsWithSize,
-        pprRules
+        pprRules, ppIdInfo
     ) where
 
 import CoreSyn
index 4e1c828..c1dbc29 100644 (file)
@@ -57,8 +57,8 @@ make_constr_itbls hsc_env cons =
                     | arg <- dataConRepArgTys dcon
                     , rep_arg <- flattenRepType (repType arg) ]
 
-         (tot_wds, ptr_wds, _) =
-             mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
+         (tot_wds, ptr_wds, _, []) =
+             mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args 0
 
          ptrs'  = ptr_wds
          nptrs' = tot_wds - ptr_wds
index bfeb785..55d6608 100644 (file)
@@ -61,7 +61,7 @@ defaults
    can_fail         = False   -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp
    commutable       = False
    code_size        = { primOpCodeSizeDefault }
-   strictness       = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes }
+   strictness       = { \ arity -> mkClosedStrictSig (replicate arity (boringTopDmd "primop")) topRes }
    fixity           = Nothing
    llvm_only        = False
    vector           = []
@@ -1963,7 +1963,7 @@ primop  CatchOp "catch#" GenPrimOp
    with
    strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
                                                  , lazyApply2Dmd
-                                                 , topDmd] topRes }
+                                                 , (boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -1972,7 +1972,7 @@ primop  RaiseOp "raise#" GenPrimOp
    b -> o
       -- NB: the type variable "o" is "a", but with OpenKind
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [(boringTopDmd "primop")] exnRes }
       -- NB: result is ThrowsExn
    out_of_line = True
    has_side_effects = True
@@ -1994,7 +1994,7 @@ primop  RaiseOp "raise#" GenPrimOp
 primop  RaiseIOOp "raiseIO#" GenPrimOp
    a -> State# RealWorld -> (# State# RealWorld, b #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [(boringTopDmd "primop"), (boringTopDmd "primop")] exnRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2002,7 +2002,7 @@ primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2011,7 +2011,7 @@ primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2019,7 +2019,7 @@ primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2040,7 +2040,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
       (State# RealWorld -> (# State# RealWorld, a #) )
    -> State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2058,7 +2058,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
 primop  RetryOp "retry#" GenPrimOp
    State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [(boringTopDmd "primop")] botRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2069,7 +2069,7 @@ primop  CatchRetryOp "catchRetry#" GenPrimOp
    with
    strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
                                                  , lazyApply1Dmd
-                                                 , topDmd ] topRes }
+                                                 , (boringTopDmd "primop") ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2081,7 +2081,7 @@ primop  CatchSTMOp "catchSTM#" GenPrimOp
    with
    strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
                                                  , lazyApply2Dmd
-                                                 , topDmd ] topRes }
+                                                 , (boringTopDmd "primop") ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2945,7 +2945,7 @@ primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp
 
 primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 ----
 
@@ -2963,7 +2963,7 @@ primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp
 
 primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp
    a ->  State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 ----
 
@@ -2981,7 +2981,7 @@ primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp
 
 primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 ----
 
@@ -2999,7 +2999,7 @@ primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp
 
 primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 
 ------------------------------------------------------------------------
index 2c72266..0dc87fb 100644 (file)
@@ -133,7 +133,7 @@ statRhs top (_, StgRhsClosure _ _ fv u _ body)
     countOne (
       case u of
         ReEntrant   -> ReEntrantBinds   top
-        Updatable   -> UpdatableBinds   top
+        Updatable _ -> UpdatableBinds   top
         SingleEntry -> SingleEntryBinds top
     )
 
index 00c6853..6edd930 100644 (file)
@@ -1698,7 +1698,7 @@ calcSpecStrictness fn qvars pats
     go env _      _                = env
 
     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
-    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
+    go_one env d   (Var v) = extendVarEnv_C (bothDmd "spec") env v d
     go_one env d e
            | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
            , (Var _, args) <- collectArgs e = go env ds args
index 273cbdb..4ab1b88 100644 (file)
@@ -41,7 +41,7 @@ import FastString
 import Util
 import DynFlags
 import ForeignCall
-import Demand           ( isUsedOnce )
+import Demand           ( isUsedOnce, isBoringDemand )
 import PrimOp           ( PrimCall(..) )
 
 import Data.Maybe    (isJust)
@@ -780,7 +780,7 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
     (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
     upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
-             | otherwise                      = Updatable
+             | otherwise                      = Updatable (isBoringDemand (idDemandInfo bndr))
 
   {-
     SDM: disabled.  Eval/Apply can't handle functions with arity zero very
index f3a02c8..e65afe3 100644 (file)
@@ -18,7 +18,7 @@ module StgSyn (
         GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
-        UpdateFlag(..), isUpdatable,
+        UpdateFlag(..), isUpdatable, isBoring,
 
         StgBinderInfo,
         noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
@@ -575,18 +575,24 @@ closure will only be entered once, and so need not be updated but may
 safely be blackholed.
 -}
 
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
+-- Bool: True <=> Boring
+data UpdateFlag = ReEntrant | Updatable [String] | SingleEntry
 
 instance Outputable UpdateFlag where
     ppr u = char $ case u of
                        ReEntrant   -> 'r'
-                       Updatable   -> 'u'
+                       Updatable _ -> 'u'
                        SingleEntry -> 's'
 
 isUpdatable :: UpdateFlag -> Bool
 isUpdatable ReEntrant   = False
 isUpdatable SingleEntry = False
-isUpdatable Updatable   = True
+isUpdatable (Updatable _)  = True
+
+isBoring :: UpdateFlag -> [String]
+isBoring ReEntrant   = []
+isBoring SingleEntry = []
+isBoring (Updatable b)  = b
 
 {-
 ************************************************************************
index 53144ff..36fa450 100644 (file)
@@ -510,7 +510,7 @@ dmdFix top_lvl env orig_pairs
           = ((env', lazy_fv'), (id', rhs'))
           where
             (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
-            lazy_fv'                   = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            lazy_fv'                   = plusVarEnv_C (bothDmd "fix") lazy_fv lazy_fv1
             env'                       = extendAnalEnv top_lvl env id sig
 
     same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
@@ -528,7 +528,7 @@ dmdAnalRhs :: TopLevelFlag
 dmdAnalRhs top_lvl rec_flag env id rhs
   | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]
   , let fn_str = getStrictness env fn
-        fn_fv | isLocalId fn = unitVarEnv fn topDmd
+        fn_fv | isLocalId fn = unitVarEnv fn (boringTopDmd "fn_fv")
               | otherwise    = emptyDmdEnv
         -- Note [Remember to demand the function itself]
         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -560,7 +560,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
     -- See Note [Lazy and unleashable free variables]
     -- See Note [Aggregated demand for cardinality]
     rhs_fv1 = case rec_flag of
-                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
+                Just bs -> reuseEnv "fix" (delVarEnvList rhs_fv bs)
                 Nothing -> rhs_fv
 
     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
@@ -641,12 +641,12 @@ unitDmdType :: DmdEnv -> DmdType
 unitDmdType dmd_env = DmdType dmd_env [] topRes
 
 coercionDmdEnv :: Coercion -> DmdEnv
-coercionDmdEnv co = mapVarEnv (const topDmd) (coVarsOfCo co)
+coercionDmdEnv co = mapVarEnv (const (boringTopDmd "coercion")) (coVarsOfCo co)
                     -- The VarSet from coVarsOfCo is really a VarEnv Var
 
 addVarDmd :: DmdType -> Var -> Demand -> DmdType
 addVarDmd (DmdType fv ds res) var dmd
-  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
+  = DmdType (extendVarEnv_C (bothDmd "dmdTransformFix") fv var dmd) ds res
 
 addLazyFVs :: DmdType -> DmdEnv -> DmdType
 addLazyFVs dmd_ty lazy_fvs
@@ -1057,7 +1057,7 @@ addDataConStrictness con ds
   where
     strs = dataConRepStrictness con
     add dmd str | isMarkedStrict str
-                , not (isAbsDmd dmd) = dmd `bothDmd` seqDmd
+                , not (isAbsDmd dmd) = bothDmd "strdatacon" dmd seqDmd
                 | otherwise          = dmd
 
 findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
index 80d966b..f22128c 100644 (file)
@@ -405,7 +405,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
             -- See Note [Demand on the Worker]
             single_call = saturatedByOneShots arity (demandInfo fn_info)
             worker_demand | single_call = mkWorkerDemand work_arity
-                          | otherwise   = topDmd
+                          | otherwise   = boringTopDmd "worker"
 
                                 -- arity is consistent with the demand type goes through
 
index ff4d44a..0372922 100644 (file)
    The StgEntCounter type - needed regardless of TICKY_TICKY
    -------------------------------------------------------------------------- */
 
+/*
+ * Changes here must be reflected in emitTickyCounter in StgCmmTicky.hs.
+ */
+
 typedef struct _StgEntCounter {
   /* Using StgWord for everything, because both the C and asm code
      generators make trouble if you try to pack things tighter */
     StgWord     registeredp;    /* 0 == no, 1 == yes */
     StgInt      arity;          /* arity (static info) */
-    StgInt      allocd;         /* # allocation of this closure */
+    StgInt      allocd_count;   /* instances allocated of this closure */
+    StgInt      allocd;         /* bytes allocates for this closure */
                                 /* (rest of args are in registers) */
     char        *str;           /* name of the thing */
     char        *arg_kinds;     /* info about the args types */
     StgInt      entry_count;    /* Trips to fast entry code */
+    StgInt      single_entry_count;  /* How many instance with a single entry */
+    StgInt      multi_entry_count;  /* How many instance with multiple entries */
     StgInt      allocs;         /* number of allocations by this fun */
     struct _StgEntCounter *link;/* link to chain them all together */
 } StgEntCounter;
index 4ebec0f..eb22afe 100644 (file)
@@ -396,6 +396,7 @@ closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)
     case PAP:
         return pap_sizeW((StgPAP *)p);
     case IND:
+    case COUNTING_IND:
         return sizeofW(StgInd);
     case ARR_WORDS:
         return arr_words_sizeW((StgArrBytes *)p);
index 4f66de3..ad58e56 100644 (file)
 #define PAP                     26
 #define AP_STACK                27
 #define IND                     28
-#define IND_STATIC              29
-#define RET_BCO                 30
-#define RET_SMALL               31
-#define RET_BIG                 32
-#define RET_FUN                 33
-#define UPDATE_FRAME            34
-#define CATCH_FRAME             35
-#define UNDERFLOW_FRAME         36
-#define STOP_FRAME              37
-#define BLOCKING_QUEUE          38
-#define BLACKHOLE               39
-#define MVAR_CLEAN              40
-#define MVAR_DIRTY              41
-#define TVAR                    42
-#define ARR_WORDS               43
-#define MUT_ARR_PTRS_CLEAN      44
-#define MUT_ARR_PTRS_DIRTY      45
-#define MUT_ARR_PTRS_FROZEN0    46
-#define MUT_ARR_PTRS_FROZEN     47
-#define MUT_VAR_CLEAN           48
-#define MUT_VAR_DIRTY           49
-#define WEAK                    50
-#define PRIM                    51
-#define MUT_PRIM                52
-#define TSO                     53
-#define STACK                   54
-#define TREC_CHUNK              55
-#define ATOMICALLY_FRAME        56
-#define CATCH_RETRY_FRAME       57
-#define CATCH_STM_FRAME         58
-#define WHITEHOLE               59
-#define SMALL_MUT_ARR_PTRS_CLEAN      60
-#define SMALL_MUT_ARR_PTRS_DIRTY      61
-#define SMALL_MUT_ARR_PTRS_FROZEN0    62
-#define SMALL_MUT_ARR_PTRS_FROZEN     63
-#define N_CLOSURE_TYPES         64
+#define COUNTING_IND            29
+#define IND_STATIC              30
+#define RET_BCO                 31
+#define RET_SMALL               32
+#define RET_BIG                 33
+#define RET_FUN                 34
+#define UPDATE_FRAME            35
+#define CATCH_FRAME             36
+#define UNDERFLOW_FRAME         37
+#define STOP_FRAME              38
+#define BLOCKING_QUEUE          39
+#define BLACKHOLE               40
+#define MVAR_CLEAN              41
+#define MVAR_DIRTY              42
+#define TVAR                    43
+#define ARR_WORDS               44
+#define MUT_ARR_PTRS_CLEAN      45
+#define MUT_ARR_PTRS_DIRTY      46
+#define MUT_ARR_PTRS_FROZEN0    47
+#define MUT_ARR_PTRS_FROZEN     48
+#define MUT_VAR_CLEAN           49
+#define MUT_VAR_DIRTY           50
+#define WEAK                    51
+#define PRIM                    52
+#define MUT_PRIM                53
+#define TSO                     54
+#define STACK                   55
+#define TREC_CHUNK              56
+#define ATOMICALLY_FRAME        57
+#define CATCH_RETRY_FRAME       58
+#define CATCH_STM_FRAME         59
+#define WHITEHOLE               60
+#define SMALL_MUT_ARR_PTRS_CLEAN      61
+#define SMALL_MUT_ARR_PTRS_DIRTY      62
+#define SMALL_MUT_ARR_PTRS_FROZEN0    63
+#define SMALL_MUT_ARR_PTRS_FROZEN     64
+#define N_CLOSURE_TYPES         65
 
 #endif /* RTS_STORAGE_CLOSURETYPES_H */
index f880b5c..88e0831 100644 (file)
@@ -121,6 +121,13 @@ typedef struct {
 } StgInd;
 
 typedef struct {
+    StgHeader   header;
+    StgClosure *indirectee;
+    const void *ent_counter; // A StgEntCounter
+    StgWord     entries;
+} StgCountingInd;
+
+typedef struct {
     StgHeader     header;
     StgClosure   *indirectee;
     StgClosure   *static_link;
index 731893e..570d8be 100644 (file)
@@ -86,6 +86,7 @@ RTS_RET(stg_apply_interp);
 RTS_ENTRY(stg_IND);
 RTS_ENTRY(stg_IND_direct);
 RTS_ENTRY(stg_IND_STATIC);
+RTS_ENTRY(stg_COUNTING_IND);
 RTS_ENTRY(stg_BLACKHOLE);
 RTS_ENTRY(stg_CAF_BLACKHOLE);
 RTS_ENTRY(__stg_EAGER_BLACKHOLE);
index d303315..b80e357 100644 (file)
@@ -137,6 +137,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
                 size = sizeW_fromITBL(info);
                 break;
 
+            case COUNTING_IND:
             case BLACKHOLE:
             case BLOCKING_QUEUE:
                 prim = rtsTrue;
index cd2c7e1..337c82a 100644 (file)
@@ -50,6 +50,7 @@ StgWord16 closure_flags[] = {
  [PAP]                  =  (_HNF|     _NS                                ),
  [AP_STACK]             =  (                   _THU                      ),
  [IND]                  =  (          _NS|                        _IND ),
+ [COUNTING_IND]         =  (          _NS|                        _IND ),
  [IND_STATIC]           =  (          _NS|_STA|                   _IND ),
  [RET_BCO]              =  ( 0                                         ),
  [RET_SMALL]            =  (     _BTM|                       _SRT      ),
@@ -87,6 +88,6 @@ StgWord16 closure_flags[] = {
  [SMALL_MUT_ARR_PTRS_FROZEN]  =  (_HNF|     _NS|              _UPT           )
 };
 
-#if N_CLOSURE_TYPES != 64
+#if N_CLOSURE_TYPES != 65
 #error Closure types changed: update ClosureFlags.c!
 #endif
index f88e474..e0af19b 100644 (file)
@@ -330,6 +330,7 @@ eval_obj:
     switch ( get_itbl(obj)->type ) {
 
     case IND:
+    case COUNTING_IND:
     case IND_STATIC:
     {
         tagged_obj = ((StgInd*)obj)->indirectee;
index 428078b..415cd72 100644 (file)
@@ -109,6 +109,7 @@ processHeapClosureForDead( const StgClosure *c )
     case FUN_0_2:
     case BLACKHOLE:
     case BLOCKING_QUEUE:
+    case COUNTING_IND:
         /*
           'Ingore' cases
         */
index 1ee1c6c..a1b0ff0 100644 (file)
@@ -232,6 +232,12 @@ printClosure( const StgClosure *obj )
             debugBelch(")\n");
             break;
 
+    case COUNTING_IND:
+            debugBelch("COUNTING_IND(");
+            printPtr((StgPtr)((StgInd*)obj)->indirectee);
+            debugBelch(")\n");
+            break;
+
     case IND_STATIC:
             debugBelch("IND_STATIC(");
             printPtr((StgPtr)((StgInd*)obj)->indirectee);
@@ -843,6 +849,7 @@ const char *closure_type_names[] = {
  [PAP]                   = "PAP",
  [AP_STACK]              = "AP_STACK",
  [IND]                   = "IND",
+ [COUNTING_IND]          = "COUNTING_IND",
  [IND_STATIC]            = "IND_STATIC",
  [RET_BCO]               = "RET_BCO",
  [RET_SMALL]             = "RET_SMALL",
index 18c3e41..88ac63e 100644 (file)
@@ -977,6 +977,7 @@ heapCensusChain( Census *census, bdescr *bd )
 
             case CONSTR:
             case FUN:
+            case COUNTING_IND:
             case BLACKHOLE:
             case BLOCKING_QUEUE:
             case FUN_1_0:
index 3fe0f8b..83b4beb 100644 (file)
@@ -462,6 +462,7 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
     case THUNK_SELECTOR:
         *first_child = ((StgSelector *)c)->selectee;
         return;
+    case COUNTING_IND:
     case BLACKHOLE:
         *first_child = ((StgInd *)c)->indirectee;
         return;
@@ -929,6 +930,7 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
         case MUT_VAR_CLEAN:
         case MUT_VAR_DIRTY:
         case THUNK_SELECTOR:
+        case COUNTING_IND:
         case CONSTR_1_1:
             // cannot appear
         case PAP:
@@ -1064,9 +1066,7 @@ isRetainer( StgClosure *c )
         // partial applications
     case PAP:
         // indirection
-    // IND_STATIC used to be an error, but at the moment it can happen
-    // as isAlive doesn't look through IND_STATIC as it ignores static
-    // closures. See trac #3956 for a program that hit this error.
+    case COUNTING_IND:
     case IND_STATIC:
     case BLACKHOLE:
         // static objects
index e66b4d8..32c6528 100644 (file)
       SymI_HasProto(stg_MVAR_DIRTY_info)                                \
       SymI_HasProto(stg_TVAR_CLEAN_info)                                \
       SymI_HasProto(stg_TVAR_DIRTY_info)                                \
+      SymI_HasProto(stg_COUNTING_IND_info)                                  \
       SymI_HasProto(stg_IND_STATIC_info)                                \
       SymI_HasProto(stg_ARR_WORDS_info)                                 \
       SymI_HasProto(stg_MUT_ARR_PTRS_DIRTY_info)                        \
index 9f34072..ffe69ba 100644 (file)
@@ -355,6 +355,7 @@ removeIndirections (StgClosure* p)
         switch (get_itbl(q)->type) {
         case IND:
         case IND_STATIC:
+        case COUNTING_IND:
             p = ((StgInd *)q)->indirectee;
             continue;
 
index 905f81e..0f27fdb 100644 (file)
@@ -258,6 +258,50 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC")
     jump %GET_ENTRY(R1) [R1];
 }
 
+INFO_TABLE(stg_COUNTING_IND,1,2,COUNTING_IND,"COUNTING_IND","COUNTING_IND")
+    /* explicit stack */
+{
+    W_ tag, clos, entries, ent_ctr;
+    /* Don't add INDs to granularity cost */
+
+    /* Don't: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is
+       here only to help profiling */
+
+    // Preserve tag
+    clos = UNTAG(R1);
+    tag = GETTAG(R1);
+
+    // ccall debugBelch("COUNTING_IND %p %p %d\n", StgInd_indirectee(clos), StgCountingInd_ent_counter(clos), StgCountingInd_entries(clos));
+
+    ent_ctr = StgCountingInd_ent_counter(clos);
+    entries = StgCountingInd_entries(clos);
+    if (entries == 0) {
+        StgEntCounter_single_entry_count(ent_ctr) = StgEntCounter_single_entry_count(ent_ctr) +1;
+    }
+    if (entries == 1) {
+        StgEntCounter_single_entry_count(ent_ctr) = StgEntCounter_single_entry_count(ent_ctr) - 1;
+        StgEntCounter_multi_entry_count(ent_ctr)  = StgEntCounter_multi_entry_count(ent_ctr) + 1;
+    }
+    StgCountingInd_entries(clos) = entries + 1;
+    StgEntCounter_entry_count(ent_ctr) = StgEntCounter_entry_count(ent_ctr) + 1;
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+    /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than
+       being extra  */
+    TICK_ENT_PERM_IND();
+#endif
+
+    LDV_ENTER(R1);
+
+    R1 = UNTAG(StgCountingInd_indirectee(clos))+tag;
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+    TICK_ENT_VIA_NODE();
+#endif
+
+    jump %GET_ENTRY(UNTAG(R1)) [R1];
+}
+
 /* ----------------------------------------------------------------------------
    Black holes.
 
index 44d49b6..ffc3941 100644 (file)
  * here.
  */
 StgEntCounter top_ct
-        = { 0, 0, 0,
+        = { 0, 0, 0, 0,
             "TOP", "",
-            0, 0, NULL };
+            0, 0, 0, 0,
+           NULL };
 
 /* Data structure used in ``registering'' one of these counters. */
 
@@ -356,16 +357,26 @@ printRegisteredCounterInfo (FILE *tf)
       fprintf(tf,"\nThe following table is explained by http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky\nAll allocation numbers are in bytes.\n");
       fprintf(tf,"\n**************************************************\n\n");
     }
-    fprintf(tf, "%11s%11s%11s  %-23s %s\n",
-            "Entries", "Alloc", "Alloc'd", "Non-void Arguments", "STG Name");
+    fprintf(tf, "%11s%11s%11s%11s%11s%11s  %-23s %s\n",
+            "Entries", "Alloc", "Alloc'd", "#Alloc", "Single", "Multiple", "Non-void Arguments", "STG Name");
     fprintf(tf, "--------------------------------------------------------------------------------\n");
     /* Function name at the end so it doesn't mess up the tabulation */
 
     for (p = ticky_entry_ctrs; p != NULL; p = p->link) {
-        fprintf(tf, "%11" FMT_Int "%11" FMT_Int "%11" FMT_Int " %3lu %-20.20s %s",
+        fprintf(tf,
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            " %3lu %-20.20s %s",
                 p->entry_count,
                 p->allocs,
                 p->allocd,
+                p->allocd_count,
+                p->single_entry_count,
+                p->multi_entry_count,
                 (unsigned long)p->arity,
                 p->arg_kinds,
                 p->str);
index ec178e9..c391fc1 100644 (file)
@@ -650,6 +650,7 @@ thread_obj (const StgInfoTable *info, StgPtr p)
     }
 
     case IND:
+    case COUNTING_IND:
         thread(&((StgInd *)p)->indirectee);
         return p + sizeofW(StgInd);
 
index e53461d..a115269 100644 (file)
@@ -601,6 +601,7 @@ loop:
       return;
 
   case FUN:
+  case COUNTING_IND:
   case CONSTR:
       copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag);
       return;
@@ -964,6 +965,7 @@ selector_loop:
                   info = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr);
                   switch (info->type) {
                   case IND:
+                  case COUNTING_IND:
                   case IND_STATIC:
                       val = ((StgInd *)val)->indirectee;
                       goto val_loop;
@@ -1001,6 +1003,12 @@ selector_loop:
           selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
           goto selector_loop;
 
+      case COUNTING_IND:
+          // do not short cut a COUNTING_IND, as we would miss a the count
+         // Can we simply tick the counter here? Not really: If this selector
+         // thunk is not going to be used, we counted more than we wanted!
+          goto bale_out;
+
       case BLACKHOLE:
       {
           StgClosure *r;
index 6265bf9..5242255 100644 (file)
@@ -88,6 +88,7 @@ isAlive(StgClosure *p)
 
     case IND:
     case IND_STATIC:
+    case COUNTING_IND:
       // follow indirections
       p = ((StgInd *)q)->indirectee;
       continue;
index 62d53e0..60a9f27 100644 (file)
@@ -276,6 +276,7 @@ checkClosure( const StgClosure* p )
     case CONSTR_1_1:
     case CONSTR_0_2:
     case CONSTR_2_0:
+    case COUNTING_IND:
     case BLACKHOLE:
     case PRIM:
     case MUT_PRIM:
index 18a30d3..a49b85d 100644 (file)
@@ -582,6 +582,11 @@ scavenge_block (bdescr *bd)
         break;
     }
 
+    case COUNTING_IND:
+        evacuate(&((StgCountingInd *)p)->indirectee);
+        p += sizeofW(StgCountingInd);
+        break;
+
     case BLACKHOLE:
         evacuate(&((StgInd *)p)->indirectee);
         p += sizeofW(StgInd);
@@ -981,6 +986,12 @@ scavenge_mark_stack(void)
             break;
         }
 
+        case COUNTING_IND:
+            // don't need to do anything here: the only possible case
+            // is that we're in a 1-space compacting collector, with
+            // no "old" generation.
+            break;
+
         case IND:
         case BLACKHOLE:
             evacuate(&((StgInd *)p)->indirectee);
@@ -1289,6 +1300,7 @@ scavenge_one(StgPtr p)
     case CONSTR_0_2:
     case CONSTR_2_0:
     case PRIM:
+    case COUNTING_IND:
     {
         StgPtr q, end;
 
index 63e2233..2794842 100644 (file)
@@ -415,10 +415,13 @@ wanteds os = concat
           ,closurePayload C "StgClosure" "payload"
 
           ,structFieldH Both "StgEntCounter" "allocs"
+          ,structFieldH Both "StgEntCounter" "allocd_count"
           ,structFieldH Both "StgEntCounter" "allocd"
           ,structField  Both "StgEntCounter" "registeredp"
           ,structField  Both "StgEntCounter" "link"
           ,structField  Both "StgEntCounter" "entry_count"
+          ,structField  Both "StgEntCounter" "single_entry_count"
+          ,structField  Both "StgEntCounter" "multi_entry_count"
 
           ,closureSize Both "StgUpdateFrame"
           ,closureSize C    "StgCatchFrame"
@@ -484,6 +487,10 @@ wanteds os = concat
 
           ,closureFieldGcptr C "StgInd" "indirectee"
 
+          ,closureFieldGcptr Both "StgCountingInd" "indirectee"
+          ,closureField Both "StgCountingInd" "ent_counter"
+          ,closureField Both "StgCountingInd" "entries"
+
           ,closureSize  C "StgMutVar"
           ,closureField C "StgMutVar" "var"
 
index b8208ae..9f9ad4b 100644 (file)
@@ -655,6 +655,7 @@ genApply regstatus args =
 --        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
 --        print "    [IND]            &&ind_lbl,"
 --        print "    [IND_STATIC]      &&ind_lbl,"
+--        print "    [COUNTING_IND]       &&ind_lbl,"
 --        print "  };"
 
        tickForArity (length args),
@@ -773,7 +774,8 @@ genApply regstatus args =
 --        print "    ind_lbl:"
 --    else:
         text "case IND,",
-        text "     IND_STATIC: {",
+        text "     IND_STATIC,",
+        text "     COUNTING_IND: {",
         nest 4 (vcat [
           text "R1 = StgInd_indirectee(R1);",
             -- An indirection node might contain a tagged pointer