[commit: ghc] wip/kavon-nosplit-llvm: can now compile with RK debugging output (94f2d93)

[git at git.haskell.org]

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

On branch  : wip/kavon-nosplit-llvm
Link       : http://ghc.haskell.org/trac/ghc/changeset/94f2d93c6b7fe9f77d6cc20cfb0e71c190a40057/ghc

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

commit 94f2d93c6b7fe9f77d6cc20cfb0e71c190a40057
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Wed Aug 23 16:34:50 2017 -0500

    can now compile with RK debugging output


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

94f2d93c6b7fe9f77d6cc20cfb0e71c190a40057
 compiler/codeGen/StgCmmBind.hs  | 13 +++++++++----
 compiler/codeGen/StgCmmExpr.hs  |  2 +-
 compiler/codeGen/StgCmmMonad.hs | 36 +++++++++++++++++++++++++-----------
 3 files changed, 35 insertions(+), 16 deletions(-)

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 48308bc..31cfc2f 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -514,12 +514,17 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 
   }
 
+-- start of temporary debugging utils --
+
 retK2s :: ReturnKind -> String  
-retK2s (AssignedDirectly tys) = "AssignedDirectly with types: " ++ tyStr
-    where 
-        tyStr = concat [showSDocUnsafe (ppr t) ++ ", " | t <- tys]
+retK2s (AssignedDirectly tys) = "AssignedDirectly with types: " ++ cmmTy2String tys
+retK2s (ReturnedTo _ _ _) = panic "unexpected ReturnedTo from codegenning function body."
+
+cmmTy2String :: [CmmType] -> String
+cmmTy2String tys = concat [showSDocUnsafe (ppr t) ++ ", " | t <- tys]
+
+-- end of temporary debugging utils --
 
-retK2s (ReturnedTo _ _ _) = "ReturnedTo"
 
 -- Note [NodeReg clobbered with loopification]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 924b0a7..c2898ba 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -703,7 +703,7 @@ cgAltRhss gc_plan bndr alts = do
 
 maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
 maybeAltHeapCheck (NoGcInAlts,_)  code = code
-maybeAltHeapCheck (GcInAlts regs, AssignedDirectly []) code =
+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly _) code =
   altHeapCheck regs code
 maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off retRegs) code =
   altHeapCheckReturnsTo regs lret retRegs off code
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 54161d6..b34c8d9 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs, UnboxedTuples #-}
+{-# LANGUAGE CPP, GADTs, UnboxedTuples, BangPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -248,21 +248,35 @@ combineReturnKinds rks = foldl combine bot rks
         bot = AssignedDirectly []
         
         combine (AssignedDirectly a) (AssignedDirectly b) = 
-            AssignedDirectly $ merge a b
-        combine _ _ = panic "combineReturnKinds: unexpected ReturnedTo"
-        -- ReturnedTo should not appear in a tail position.
+            AssignedDirectly $ tryMerge a b
+        combine (a @ (AssignedDirectly _)) (ReturnedTo _ _ _) = a  
+        -- a branch that returns to some other block does not directly return
+        -- from this case, so we skip over it.
+        
+        combine _ _ = panic "combineReturnKinds: unexpected situation"
+        
+        tryMerge a b = res
+            where
+                !x = trace ("\ntrying to merge: \n\t[" ++ cmmTy2String a ++ "]\n\t[" ++ cmmTy2String b ++ "]\n") ()
+                res = merge a b
         
         -- [] indicates either no information, or nothing is returned.
-        merge [] ty = ty
-        merge ty [] = ty
+        -- also, if two type lists do not match in length, we only check
+        -- up to the shortest list, and pick the longest since it has "more information". 
+        -- I believe we need to do this because some branches may not explicitly assign anything
+        -- to be returned? - TODO(kavon)
+        
         merge ty1 ty2 
-            | ty1 `equals` ty2  = ty1 
+            | ty1 `equals` ty2  = if length ty1 >= length ty2 then ty1 else ty2
             | otherwise         = panic "combineReturnKinds: non-matching return kind!"
         
-         -- CmmType does not derive Eq
-        equals [] [] = True
-        equals (x:xs) (y:ys) = cmmEqType x y && equals xs ys
-        equals _ _ = False
+        equals [] _ = True
+        equals _ [] = True
+        equals (x:xs) (y:ys) = cmmEqType_ignoring_ptrhood x y && equals xs ys
+        -- equals _ _ = False
+        
+        cmmTy2String :: [CmmType] -> String
+        cmmTy2String tys = concat [showSDocUnsafe (ppr t) ++ ", " | t <- tys]
         
 
 -- Note [sharing continuations]