From 12decb2a4a78509ef6874c9e6111f9f0e2beeb0b Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Fri, 17 Apr 2020 20:17:18 +0000
Subject: XXX: Tracing

---
 compiler/GHC/StgToCmm/Bind.hs    |  5 +++--
 compiler/GHC/StgToCmm/Closure.hs |  9 ++++++++-
 compiler/GHC/StgToCmm/Env.hs     | 16 +++++++++-------
 3 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 8db97d8083..25d3a92ffb 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -500,7 +500,8 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                     (CmmMachOp (mo_wordSub platform)
                          [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
                          , mkIntExpr platform (funTag dflags cl_info) ])
-                ; fv_bindings <- mapM bind_fv fv_details
+                ; fv_bindings <- pprTrace "closureBodyBody" (ppr bndr $$ ppr body)
+                    $ mapM bind_fv fv_details
                 -- Load free vars out of closure *after*
                 -- heap check, to reduce live vars over check
                 ; when node_points $ load_fvs node lf_info fv_bindings
@@ -523,7 +524,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 
 -- A function closure pointer may be tagged, so we
 -- must take it into account when accessing the free variables.
-bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
+bind_fv :: HasCallStack => (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
 
 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 8ab4fa6b0f..e947f35055 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -232,6 +232,13 @@ data LambdaFormInfo
 
   | LFLetNoEscape       -- See LetNoEscape module for precise description
 
+instance Outputable LambdaFormInfo where
+  ppr LFReEntrant{} = text "re-entrant"
+  ppr LFThunk{}     = text "thunk"
+  ppr LFCon{}       = text "data-con"
+  ppr LFUnknown{}   = text "unknown"
+  ppr LFUnlifted    = text "unlifted"
+  ppr LFLetNoEscape = text "let-no-escape"
 
 -------------------------
 -- StandardFormInfo tells whether this thunk has one of
@@ -626,7 +633,7 @@ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
               _self_loop_info
   = JumpToIt blk_id lne_regs
 
-getCallMethod _ name _ _lf_info _ _ _ _ = pprPanic "Unknown call method" (ppr name)
+getCallMethod _ name _ _lf_info _ _ _loc _ = pprPanic "Unknown call method" (ppr name $$ ppr _lf_info $$ ppr _loc)
 
 -----------------------------------------------------------------------------
 --              Data types for closure information
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index 047353b89a..a927608b03 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -60,7 +60,7 @@ mkCgIdInfo id lf expr
 
 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
 litIdInfo dflags id lf lit
-  = CgIdInfo { cg_id = id, cg_lf = lf
+  = pprTrace "litIdInfo" (ppr id) $ CgIdInfo { cg_id = id, cg_lf = lf
              , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }
   where
     tag = lfDynTag dflags lf
@@ -77,7 +77,8 @@ lneIdInfo platform id regs
 
 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
 rhsIdInfo id lf_info
-  = do platform <- getPlatform
+  = pprTrace "rhsIdInfo" (ppr id) $
+    do platform <- getPlatform
        reg <- newTemp (gcWord platform)
        return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
 
@@ -177,25 +178,26 @@ getNonVoidArgAmodes (arg:args)
 --        Interface functions for binding and re-binding names
 ------------------------------------------------------------------------
 
-bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: HasCallStack => NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 -- Bind an Id to a fresh LocalReg
 bindToReg nvid@(NonVoid id) lf_info
   = do platform <- getPlatform
        let reg = idToReg platform nvid
-       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
+       pprTrace "bindToReg" (ppr id $$ ppr lf_info $$ callStackDoc)
+         $ addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        return reg
 
-rebindToReg :: NonVoid Id -> FCode LocalReg
+rebindToReg :: HasCallStack => NonVoid Id -> FCode LocalReg
 -- Like bindToReg, but the Id is already in scope, so
 -- get its LF info from the envt
 rebindToReg nvid@(NonVoid id)
   = do  { info <- getCgIdInfo id
         ; bindToReg nvid (cg_lf info) }
 
-bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg :: HasCallStack => NonVoid Id -> FCode LocalReg
 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
 
-bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
+bindArgsToRegs :: HasCallStack => [NonVoid Id] -> FCode [LocalReg]
 bindArgsToRegs args = mapM bindArgToReg args
 
 idToReg :: Platform -> NonVoid Id -> LocalReg
-- 
cgit v1.2.1