[commit: ghc] wip/T14626: WIP: an attempt to add assert code (failed, for now) (65d5f38)

[git at git.haskell.org]

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

On branch  : wip/T14626
Link       : http://ghc.haskell.org/trac/ghc/changeset/65d5f383e04692e06431f7cc43b1cc1dca40ee9c/ghc

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

commit 65d5f383e04692e06431f7cc43b1cc1dca40ee9c
Author: Gabor Greif <ggreif at gmail.com>
Date:   Wed Jan 10 22:41:24 2018 +0100

    WIP: an attempt to add assert code (failed, for now)


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

65d5f383e04692e06431f7cc43b1cc1dca40ee9c
 compiler/codeGen/StgCmmClosure.hs | 20 ++++++++++++++------
 compiler/codeGen/StgCmmExpr.hs    |  7 +++++++
 rts/Apply.cmm                     |  9 +++++++++
 3 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index ef03eee..a52707c 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RecordWildCards, LambdaCase #-}
+{-# LANGUAGE CPP, RecordWildCards, LambdaCase, PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
 --
@@ -30,7 +30,7 @@ module StgCmmClosure (
         maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
 
         -- * Used by other modules
-        CgLoc(..), SelfLoopInfo, CallMethod(..),
+        CgLoc(..), SelfLoopInfo, CallMethod(.., ReturnIt),
         nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,
 
         -- * ClosureInfo
@@ -526,12 +526,15 @@ Known fun (>1 arg), fvs     & yes & yes & registers & node
 When black-holing, single-entry closures could also be entered via node
 (rather than directly) to catch double-entry. -}
 
+pattern ReturnIt :: CallMethod
+pattern ReturnIt = ReturnIt' False
+
 data CallMethod
   = EnterIt             -- No args, not a function
 
   | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
 
-  | ReturnIt            -- It's a value (function, unboxed value,
+  | ReturnIt' Bool            -- It's a value (function, unboxed value,
                         -- or constructor), so just return it.
 
   | SlowCall                -- Unknown fun, or known fun with
@@ -626,15 +629,20 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
   = SlowCall -- might be a function
 
+
 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" || take 2 str == "ds" || pprTrace "getCallMethod#####" (ppr id $$ ppr (idUnfolding id)) True
-  , take 4 str == "wild" || take 2 str == "ds"
-  = {-pprTrace "getCallMethod" (ppr id)-} ReturnIt -- seems to come from case, must be (tagged) WHNF already
+  , 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" || (str == "ds2")
+  = pprTrace "####getCallMethod" (ppr id) ReturnIt' True -- seems to come from case, must be (tagged) WHNF already
 
 
 
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 3fcc935..32b9ccf 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -31,6 +31,7 @@ import StgCmmClosure
 
 import StgSyn
 
+import Module (rtsUnitId)
 import MkGraph
 import BlockId
 import Cmm
@@ -743,6 +744,12 @@ cgIdApp fun_id args = do
           | otherwise                -> emitReturn [fun]
           -- ToDo: does ReturnIt guarantee tagged?
 
+        ReturnIt' True -- TODO: add assertion
+          -> ASSERT( null args ) ASSERT( not (isVoidTy (idType fun_id)) )
+             do emitRtsCall rtsUnitId
+                  (fsLit "checkTagged") [(fun, AddrHint)] False
+                emitReturn [fun]
+
         EnterIt -> ASSERT( null args )  -- Discarding arguments
                    emitEnter fun
 
diff --git a/rts/Apply.cmm b/rts/Apply.cmm
index 15d8250..dde6f41 100644
--- a/rts/Apply.cmm
+++ b/rts/Apply.cmm
@@ -12,6 +12,15 @@
 
 #include "Cmm.h"
 
+checkTagged ( P_ obj )
+{
+    if (GETTAG(obj)==0) {
+        ccall debugBelch("NOT TAGGED! ");
+    }
+    return();
+}
+
+
 /* ----------------------------------------------------------------------------
  * Evaluate a closure and return it.
  *