[Git][ghc/ghc][wip/con-info] fixes

[Matthew Pickering]

Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC


Commits:
e7e615a7 by Matthew Pickering at 2020-06-03T20:34:52+01:00
fixes

- - - - -


6 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Prof.hs
- compiler/GHC/StgToCmm/Utils.hs


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -672,6 +672,9 @@ data InfoTableEnt = InfoTableEnt { infoTablePtr :: CLabel
                                  , infoTableProv :: (Module, RealSrcSpan, String) }
                                  deriving (Eq, Ord)
 
+instance Outputable InfoTableEnt where
+  ppr (InfoTableEnt l p) = ppr l <> colon <> ppr p
+
 -- Constructing Cost Center Labels
 mkCCLabel  :: CostCentre      -> CLabel
 mkCCSLabel :: CostCentreStack -> CLabel


=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -189,7 +189,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
               ticks = nubBy (flip tickishContains) $
                       bCtxsTicks bctxs ++ ticksToCopy scope
               stick = case filter isSourceTick ticks of
-                []     -> pprTraceIt "DWARF-C" cstick
+                []     -> cstick --pprTraceIt "DWARF-C" cstick
                 sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
 
 -- | Build a map of blocks sorted by their tick scopes


=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -548,7 +548,7 @@ coreToStgApp f args ticks = do
             DataConWorkId dc
               | saturated    -> do
                   u <- incDc dc
-                  return $ StgConApp dc (Just u) args'
+                  return $ StgConApp dc u args' --(Just u) args'
                     (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
 
             -- Some primitive operator that might be implemented as a library call.
@@ -920,19 +920,20 @@ lookupBinding env v = case lookupVarEnv env v of
                         Just xx -> xx
                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 
-incDc :: DataCon -> CtsM Int
+incDc :: DataCon -> CtsM (Maybe Int)
+incDc dc | isUnboxedTupleCon dc = return Nothing
 incDc dc = CtsM $ \_ _ -> do
           env <- get
           cc <- ask
           let dcMap' = alterUniqMap (maybe (Just [(0, cc)]) (\xs@((k, _):_) -> Just ((k + 1, cc) : xs))) (provDC env) dc
           put (env { provDC = dcMap' })
-          let Just r = lookupUniqMap dcMap' dc
-          return (fst (head r))
+          let r = lookupUniqMap dcMap' dc
+          return (fst . head <$> r)
 
 recordStgIdPosition :: Id -> Maybe (RealSrcSpan, String) -> CtsM ()
 recordStgIdPosition id ss = CtsM $ \_ _ -> do
   cc <- ask
-  pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr ss)
+  --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr ss)
   case firstJust ss cc of
     Nothing -> return ()
     Just r -> modify (\env -> env { provClosure = addToUniqMap (provClosure env) id r})


=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -72,7 +72,7 @@ codeGen :: DynFlags
         -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
                                        -- be interleaved with output
 
-codeGen dflags this_mod (InfoTableProvMap (dcmap@(UniqMap denv)) _) data_tycons
+codeGen dflags this_mod (InfoTableProvMap (dcmap@(UniqMap denv)) clmap) data_tycons
         cost_centre_info stg_binds hpc_info
   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
               -- Using an IORef to store the state is a bit crude, but otherwise
@@ -95,7 +95,9 @@ codeGen dflags this_mod (InfoTableProvMap (dcmap@(UniqMap denv)) _) data_tycons
                -- FIRST.  This is because when -split-objs is on we need to
                -- combine this block with its initialisation routines; see
                -- Note [pipeline-split-init].
-        ; cg (mkModuleInit cost_centre_info this_mod hpc_info (convertDCMap this_mod dcmap))
+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info
+                (((convertDCMap this_mod dcmap))
+                 ++ (convertClosureMap this_mod clmap)))
 
         ; mapM_ (cg . cgTopBinding dflags) stg_binds
 
@@ -215,8 +217,8 @@ cgDataCon :: Maybe (Module, Int) -> Maybe (RealSrcSpan, String) -> DataCon -> FC
 -- the static closure, for a constructor.
 cgDataCon _ _ data_con | isUnboxedTupleCon data_con = return ()
 cgDataCon mn ms data_con
-  = do  {  pprTraceM "cgDataCon" (ppr mn <+> ppr ms <+> ppr data_con)
-        ; dflags <- getDynFlags
+  = do  { -- pprTraceM "cgDataCon" (ppr mn <+> ppr ms <+> ppr data_con)
+          dflags <- getDynFlags
         ; platform <- getPlatform
         ; let
             (tot_wds, --  #ptr_wds + #nonptr_wds


=====================================
compiler/GHC/StgToCmm/Prof.hs
=====================================
@@ -278,7 +278,8 @@ initInfoTableProv :: [InfoTableEnt] -> FCode ()
 -- Emit the declarations
 initInfoTableProv ents
   = do dflags <- getDynFlags
-       pprTraceM "initInfoTable" (ppr (length ents))
+--       pprTraceM "initInfoTable" (ppr (length ents))
+--       pprTraceM "initInfoTable" (vcat (map ppr ents))
        mapM_ emitInfoTableProv ents
 
 --- Info Table Prov stuff


=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -635,7 +635,7 @@ emitUpdRemSetPushThunk ptr = do
 
 convertClosureMap :: Module -> ClosureMap -> [InfoTableEnt]
 convertClosureMap this_mod (UniqMap denv) =
-  map (\(bndr, (ss, l)) -> InfoTableEnt (mkClosureTableLabel (idName bndr) (idCafInfo bndr)) (this_mod, ss, l)) (nonDetEltsUFM denv)
+  map (\(bndr, (ss, l)) -> InfoTableEnt (mkClosureLabel (idName bndr) (idCafInfo bndr)) (this_mod, ss, l)) (nonDetEltsUFM denv)
 
 convertDCMap :: Module -> DCMap -> [InfoTableEnt]
 convertDCMap this_mod (UniqMap denv) =
@@ -644,4 +644,4 @@ convertDCMap this_mod (UniqMap denv) =
         Nothing -> Nothing
         Just (ss, l) -> Just $
           InfoTableEnt (mkConInfoTableLabel (dataConName dc) (Just (this_mod, k)))
-                       (this_mod, ss, l)) ns) (nonDetEltsUFM denv)
\ No newline at end of file
+                       (this_mod, ss, l)) ns) (nonDetEltsUFM denv)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7e615a7dd265c29eb433b38360638432967e6d8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7e615a7dd265c29eb433b38360638432967e6d8
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200603/b449f990/attachment-0001.html>