[commit: ghc] wip/T13861: debugging (5058f4c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T13861
Link       : http://ghc.haskell.org/trac/ghc/changeset/5058f4c22df1782d0ba1290535ab91217333239f/ghc

>---------------------------------------------------------------

commit 5058f4c22df1782d0ba1290535ab91217333239f
Author: Gabor Greif <ggreif at gmail.com>
Date:   Sat Aug 12 16:30:37 2017 +0200

    debugging


>---------------------------------------------------------------

5058f4c22df1782d0ba1290535ab91217333239f
 compiler/simplStg/StgCse.hs | 16 ++++++++++------
 1 file changed, 10 insertions(+), 6 deletions(-)

diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index 3b989a0..263f184 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -14,6 +14,7 @@ note [Case 1: CSEing allocated closures] and
 note [Case 2: CSEing case binders] below.
 
 TODOs:
+- vanilla for unpacked tuples?
 - rerun occurrence analysis
 - dumping of STG misses binder
 - does not look up in scope to find low-hanging fruit
@@ -89,8 +90,8 @@ import Data.Maybe (fromMaybe)
 import TrieMap
 import NameEnv
 import Control.Monad( (>=>) )
-import Name (NamedThing (..), mkFCallName)
-import Unique (mkUniqueGrimily)
+import Name (NamedThing (..), mkFCallName, nameUnique)
+import Unique (mkUniqueGrimily, getKey)
 
 --------------
 -- The Trie --
@@ -121,25 +122,28 @@ newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
 newtype LaxDataCon = Lax DataCon
 
 instance NamedThing LaxDataCon where
-  getName (Lax dc) | isVanillaDataCon dc && not hasStrict && not unpacked = mkFCallName uniq "" -- FIXME: is there a better way?
+  getName (Lax dc) | long && isVanillaDataCon dc && not hasStrict && not unpacked = mkFCallName uniq "" -- FIXME: is there a better way?
     where uniq = mkUniqueGrimily . negate $ dataConTag dc * 1048576 + length (dataConOrigArgTys dc) -- FIXME
           hasStrict = any (\case HsLazy -> False; _ -> True) (dataConImplBangs dc)
           unpacked = isUnboxedTupleCon dc || isUnboxedSumCon dc
+          long = length (dataConOrigArgTys dc) > 2
   getName (Lax dc) = getName dc
 
 
 instance TrieMap ConAppMap where
     type Key ConAppMap = (LaxDataCon, [StgArg])
     emptyTM  = CAM emptyTM
-    --lookupTM (dataCon, args) | traceLookup dataCon = undefined
+    lookupTM (dataCon, args) | traceLookup dataCon = undefined
     lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args
     alterTM  (dataCon, args) f m =
         m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
     foldTM k = un_cam >.> foldTM (foldTM k)
     mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM
 
---traceLookup (Lax dc) = pprTrace "lookupTM" (ppr dc) False
---{-# NOINLINE traceLookup #-}
+traceLookup l@(Lax dc) = pprTrace "lookupTM" (ppr dc <> (if getKey u < 0 then text " -" else text " ") <> ppr u') False
+  where u = nameUnique . getName $ l
+        u' = mkUniqueGrimily (abs(getKey u))
+{-# NOINLINE traceLookup #-}
 
 -----------------
 -- The CSE Env --