[commit: ghc] wip/T14626: WIP: add taggedness assert when optimizing (4a741e0)

[git at git.haskell.org]

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

On branch  : wip/T14626
Link       : http://ghc.haskell.org/trac/ghc/changeset/4a741e0a4c6cf3a1b7517bc34be12396dc91f7fb/ghc

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

commit 4a741e0a4c6cf3a1b7517bc34be12396dc91f7fb
Author: Gabor Greif <ggreif at gmail.com>
Date:   Thu Jan 11 07:27:14 2018 +0100

    WIP: add taggedness assert when optimizing


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

4a741e0a4c6cf3a1b7517bc34be12396dc91f7fb
 compiler/codeGen/StgCmmClosure.hs | 23 ++---------------------
 compiler/codeGen/StgCmmExpr.hs    |  8 +++++++-
 2 files changed, 9 insertions(+), 22 deletions(-)

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index a52707c..f33a9f3 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -632,31 +632,12 @@ getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
 
 getCallMethod _ name id (LFUnknown False) 0 _v_args _cg_loc _self_loop_info
   | isEvaldUnfolding (idUnfolding id)
-  -- , ('w':'i':'l':'d':_) <- occNameString (nameOccName name) -- FIXME: remove later
-  -- , (\case OtherCon _ -> False; _ -> True) $ idUnfolding id
   , OtherCon _ <- idUnfolding id
   , let str = occNameString (nameOccName name)
-  , take 4 str == "wild" || pprTrace "getCallMethod#####" (ppr id $$ ppr (idUnfolding id)) True
-  -- , take 4 str == "wild" || (take 2 str == "ds" && str /= "ds1" && str /= "ds2")
-  -- , take 4 str == "wild" || (str == "ds" || str == "ds1" || str == "ds2" || str == "ds3") -- CRASH
-  -- , take 4 str == "wild" || (str == "ds2" || str == "ds3") -- CRASH
-  -- , take 4 str == "wild" || (str == "ds3") -- CRASH: FastString
+  -- , take 4 str == "wild" || pprTrace "getCallMethod#####" (ppr id $$ ppr (idUnfolding id)) True
   , take 4 str == "wild" || (str == "ds2")
-  = pprTrace "####getCallMethod" (ppr id) ReturnIt' True -- seems to come from case, must be (tagged) WHNF already
+  = pprTrace "####getCallMethod" (ppr id) ReturnIt' (str == "ds2") -- seems to come from case, must be (tagged) WHNF already
 
-
-
-
-{-
-  , head str /= '$'
-  -- , ('w':'i':'l':'d':_) <- occNameString (nameOccName name) -- FIXME: remove later
-  , take 4 str == "wild" || pprTrace "getCallMethod#####" (ppr id $$ text str $$ ppr (idUnfolding id)) True
--}
-{-
-getCallMethod _ name _ (LFUnknown False) 0 _v_args _cg_loc _self_loop_info
-  | occNameString (nameOccName name) == "wild" -- TODO: make this robust
-  = ReturnIt -- seems to come from case, must be (tagged) WHNF already
--}
 getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
   = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
     EnterIt -- Not a function
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 32b9ccf..2a63f96 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -746,8 +746,14 @@ cgIdApp fun_id args = do
 
         ReturnIt' True -- TODO: add assertion
           -> ASSERT( null args ) ASSERT( not (isVoidTy (idType fun_id)) )
-             do emitRtsCall rtsUnitId
+             do lgood <- newBlockId
+                lcall <- newBlockId
+                emit $ mkCbranch (cmmIsTagged dflags fun)
+                         lgood lcall Nothing
+                emitLabel lcall
+                emitRtsCall rtsUnitId
                   (fsLit "checkTagged") [(fun, AddrHint)] False
+                emitLabel lgood
                 emitReturn [fun]
 
         EnterIt -> ASSERT( null args )  -- Discarding arguments