[Git][ghc/ghc][wip/con-info] Cleanup
Matthew Pickering
gitlab at gitlab.haskell.org
Mon Jun 8 16:12:24 UTC 2020
Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC
Commits:
2d22d5e4 by Matthew Pickering at 2020-06-08T17:12:02+01:00
Cleanup
- - - - -
15 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/StgToCmm/Env.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/StgToCmm/Monad.hs
- utils/check-api-annotations/check-api-annotations.cabal
- utils/check-ppr/check-ppr.cabal
- utils/ghc-pkg/ghc-pkg.cabal
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -166,10 +166,9 @@ data CmmInfoTable
-- GHC.Cmm.Info.Build.doSRTs.
}
-
data ProfilingInfo
= NoProfilingInfo
- | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
+ | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
-----------------------------------------------------------------------------
-- Static Data
=====================================
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
- [] -> cstick --pprTraceIt "DWARF-C" cstick
+ [] -> cstick
sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
-- | Build a map of blocks sorted by their tick scopes
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -11,7 +11,7 @@
-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.
-module GHC.CoreToStg ( coreToStg ) where
+module GHC.CoreToStg ( coreToStg ) where
#include "HsVersions.h"
@@ -46,12 +46,10 @@ import GHC.Driver.Ways
import GHC.Types.ForeignCall
import GHC.Types.Demand ( isUsedOnce )
import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
-import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Builtin.Names ( unsafeEqualityProofName )
import GHC.Data.Maybe
import Data.List.NonEmpty (nonEmpty, toList)
-import Data.Maybe (fromMaybe)
import Control.Monad (ap)
import qualified Data.Set as Set
import Control.Monad.Trans.RWS
@@ -696,13 +694,15 @@ coreToStgRhs (bndr, rhs) = do
return new_stg_rhs
-quickSourcePos (Tick (SourceNote ss m) _) = Just (ss, m)
-quickSourcePos _ = Nothing
+_quickSourcePos :: Expr b -> Maybe (RealSrcSpan, String)
+_quickSourcePos (Tick (SourceNote ss m) _) = Just (ss, m)
+_quickSourcePos _ = Nothing
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
-> Id -> StgExpr -> (StgRhs, CollectedCCs)
+
mkTopStgRhs dflags this_mod ccs bndr rhs
| StgLam bndrs body <- rhs
= -- StgLam can't have empty arguments, so not CAF
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1445,7 +1445,6 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let foreign_stubs = do
used_info <- readIORef lref
- pprTraceM "used_info" (ppr (length used_info))
let ip_init = ipInitCode used_info dflags this_mod denv
return $ foreign_stubs0 `appendStubC` prof_init `appendStubC` ip_init
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -58,7 +58,6 @@ import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
import GHC.Types.Unique.Map
-import GHC.Types.SrcLoc
codeGen :: DynFlags
@@ -88,7 +87,7 @@ codeGen dflags this_mod ip_map@(InfoTableProvMap ((UniqMap denv)) _) data_tycons
-- a big space leak. DO NOT REMOVE!
writeIORef cgref $! st'{ cgs_tops = nilOL,
cgs_stmts = mkNop }
- return a --cgs_used_info st')
+ return a
yield cmm
-- Note [codegen-split-init] the cmm_init block must come
@@ -111,11 +110,11 @@ codeGen dflags this_mod ip_map@(InfoTableProvMap ((UniqMap denv)) _) data_tycons
-- tagged.
when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
-- Emit normal info_tables, just in case
- mapM_ (cg . cgDataCon Nothing Nothing) (tyConDataCons tycon)
+ mapM_ (cg . cgDataCon Nothing) (tyConDataCons tycon)
-- Emit special info tables for everything used in this module
; mapM_ do_tycon data_tycons
- ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, ss) -> cg (cgDataCon (Just (this_mod, k)) ss dc)) (nonDetEltsUFM denv)
+ ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (Just (this_mod, k)) dc)) (nonDetEltsUFM denv)
}
---------------------------------------------------------------
@@ -170,7 +169,6 @@ cgTopBinding dflags (StgTopStringLit id str) = do
cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
---cgTopRhs _ _ bndr _ | pprTrace "cgTopRhs" (ppr bndr) False = undefined
cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn args)
= cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
-- con args are always non-void,
@@ -211,13 +209,12 @@ cgEnumerationTyCon tycon
| con <- tyConDataCons tycon]
-cgDataCon :: Maybe (Module, Int) -> Maybe (RealSrcSpan, String) -> DataCon -> FCode ()
+cgDataCon :: Maybe (Module, Int) -> DataCon -> FCode ()
-- Generate the entry code, info tables, and (for niladic constructor)
-- 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
+cgDataCon _ data_con | isUnboxedTupleCon data_con = return ()
+cgDataCon mn data_con
+ = do { dflags <- getDynFlags
; platform <- getPlatform
; let
(tot_wds, -- #ptr_wds + #nonptr_wds
@@ -227,7 +224,7 @@ cgDataCon mn ms data_con
nonptr_wds = tot_wds - ptr_wds
dyn_info_tbl =
- mkDataConInfoTable dflags data_con mn ms False ptr_wds nonptr_wds
+ mkDataConInfoTable dflags data_con mn False ptr_wds nonptr_wds
-- We're generating info tables, so we don't know and care about
-- what the actual arguments are. Using () here as the place holder.
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -90,8 +90,8 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
-- concurrent/should_run/4030 fails, for instance.
--
gen_code _ _ closure_label
- | StgApp f [] <- body, null args, isNonRec rec
- = do
+ | StgApp f [] <- body, null args, isNonRec rec
+ = do
cg_info <- getCgIdInfo f
emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
@@ -124,16 +124,14 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
cgBind :: CgStgBinding -> FCode ()
cgBind (StgNonRec name rhs)
- = do { --pprTraceM "cgBind" (ppr name)
- ; (info, fcode) <- cgRhs name rhs
+ = do { (info, fcode) <- cgRhs name rhs
; addBindC info
; init <- fcode
; emit init }
-- init cannot be used in body, so slightly better to sink it eagerly
cgBind (StgRec pairs)
- = do { --pprTraceM "cgBindRec" (ppr $ map fst pairs)
- ; r <- sequence $ unzipWith cgRhs pairs
+ = do { r <- sequence $ unzipWith cgRhs pairs
; let (id_infos, fcodes) = unzip r
; addBindsC id_infos
; (inits, body) <- getCodeR $ sequence fcodes
@@ -316,7 +314,7 @@ mkRhsClosure dflags bndr _cc
, idArity fun_id == unknownArity -- don't spoil a known call
-- Ha! an Ap thunk
- = pprTrace "AP" (ppr bndr) cgRhsStdThunk bndr lf_info payload
+ = cgRhsStdThunk bndr lf_info payload
where
n_fvs = length fvs
@@ -342,7 +340,6 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let reduced_fvs = filter (NonVoid bndr /=) fvs
- ; -- pprTraceM "DEF" (ppr bndr)
-- MAKE CLOSURE INFO FOR THIS CLOSURE
; mod_name <- getModuleName
; let name = idName bndr
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -71,8 +71,6 @@ import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.Ppr.Expr() -- For Outputable instances
-import GHC.Types.SrcLoc
-
import GHC.Types.CostCentre
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
@@ -949,8 +947,8 @@ getTyLitDescription l =
-- CmmInfoTable-related things
--------------------------------------
-mkDataConInfoTable :: DynFlags -> DataCon -> Maybe (Module, Int) -> Maybe (RealSrcSpan, String) -> Bool -> Int -> Int -> CmmInfoTable
-mkDataConInfoTable dflags data_con mn mspn is_static ptr_wds nonptr_wds
+mkDataConInfoTable :: DynFlags -> DataCon -> Maybe (Module, Int) -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable dflags data_con mn is_static ptr_wds nonptr_wds
= CmmInfoTable { cit_lbl = info_lbl
, cit_rep = sm_rep
, cit_prof = prof
@@ -958,7 +956,7 @@ mkDataConInfoTable dflags data_con mn mspn is_static ptr_wds nonptr_wds
, cit_clo = Nothing }
where
name = dataConName data_con
- info_lbl = mkConInfoTableLabel name mn
+ info_lbl = mkConInfoTableLabel name mn
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
-- We keep the *zero-indexed* tag in the srt_len field
@@ -968,11 +966,7 @@ mkDataConInfoTable dflags data_con mn mspn is_static ptr_wds nonptr_wds
| otherwise = ProfilingInfo ty_descr val_descr
ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
- val_descr = BS8.pack $ (occNameString $ getOccName data_con) ++ span_string
-
- span_string = case mspn of
- Nothing -> ""
- Just (spn, f) -> f ++ ":" ++ show (srcSpanStartLine spn) ++ ":" ++ show (srcSpanStartCol spn)
+ val_descr = BS8.pack $ (occNameString $ getOccName data_con)
-- We need a black-hole closure info to pass to @allocDynClosure@ when we
-- want to allocate the black hole on entry to a CAF.
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -30,8 +30,6 @@ import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
-import GHC.Types.SrcLoc
-
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
@@ -114,7 +112,7 @@ cgTopRhsCon dflags id con mn args
-- we're not really going to emit an info table, so having
-- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
-- needs to poke around inside it.
- info_tbl = mkDataConInfoTable dflags con ((this_mod,) <$> mn) Nothing True ptr_wds nonptr_wds
+ info_tbl = mkDataConInfoTable dflags con ((this_mod,) <$> mn) True ptr_wds nonptr_wds
; payload <- mapM mk_payload nv_args_w_offsets
@@ -147,12 +145,11 @@ buildDynCon :: Id -- Name of the thing to which this constr will
-- Return details about how to find it and initialization code
buildDynCon binder mn actually_bound cc con args
= do dflags <- getDynFlags
- spn <- getEnclosingSpan
- buildDynCon' dflags binder mn spn actually_bound cc con args
+ buildDynCon' dflags binder mn actually_bound cc con args
buildDynCon' :: DynFlags
- -> Id -> Maybe Int -> Maybe (RealSrcSpan, String)
+ -> Id -> Maybe Int
-> Bool
-> CostCentreStack
-> DataCon
@@ -170,13 +167,13 @@ the addr modes of the args is that we may be in a "knot", and
premature looking at the args will cause the compiler to black-hole!
-}
-buildDynCon' dflags binder _ _ _ _cc con args
+buildDynCon' dflags binder _ _ _cc con args
| Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args
-- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True
= return (cgInfo, return mkNop)
-------- buildDynCon': the general case -----------
-buildDynCon' dflags binder mn spn actually_bound ccs con args
+buildDynCon' dflags binder mn actually_bound ccs con args
= do { (id_info, reg) <- rhsIdInfo binder lf_info
; return (id_info, gen_code reg)
}
@@ -188,7 +185,7 @@ buildDynCon' dflags binder mn spn actually_bound ccs con args
; let (tot_wds, ptr_wds, args_w_offsets)
= mkVirtConstrOffsets dflags (addArgReps args)
nonptr_wds = tot_wds - ptr_wds
- info_tbl = mkDataConInfoTable dflags con ((modu,) <$> mn) spn False
+ info_tbl = mkDataConInfoTable dflags con ((modu,) <$> mn) False
ptr_wds nonptr_wds
; let ticky_name | actually_bound = Just binder
| otherwise = Nothing
=====================================
compiler/GHC/StgToCmm/Env.hs
=====================================
@@ -112,7 +112,6 @@ maybeLetNoEscape _other = Nothing
addBindC :: CgIdInfo -> FCode ()
addBindC stuff_to_bind = do
binds <- getBinds
- --pprTraceM "ADDING BIND" (ppr (cg_id stuff_to_bind) $$ ppr stuff_to_bind)
setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
addBindsC :: [CgIdInfo] -> FCode ()
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -87,8 +87,7 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
cgExpr (StgLet _ binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape _ binds expr) =
- do { -- pprTraceM "JOIN" (ppr binds)
- ; u <- newUnique
+ do { u <- newUnique
; let join_id = mkBlockId u
; cgLneBinds join_id binds
; r <- cgExpr expr
@@ -1090,6 +1089,6 @@ cgTick tick k
; case tick of
ProfNote cc t p -> emitSetCCC cc t p >> k
HpcTick m n -> emit (mkTickBox platform m n) >> k
- SourceNote s n -> emitTick (SourceNote s n) >> withEnclosingSpan s n k
+ SourceNote s n -> emitTick (SourceNote s n) >> k
_other -> k
}
=====================================
compiler/GHC/StgToCmm/Heap.hs
=====================================
@@ -52,14 +52,13 @@ import GHC.Data.FastString( mkFastString, fsLit )
import Control.Monad (when)
import Data.Maybe (isJust)
import GHC.Utils.Outputable
-import GHC.Stack (HasCallStack)
-----------------------------------------------------------
-- Initialise dynamic heap objects
-----------------------------------------------------------
allocDynClosure
- :: HasCallStack => Maybe Id
+ :: Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr -- Cost Centre to stick in the object
@@ -97,7 +96,6 @@ allocDynClosureCmm
allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do
let (args, offsets) = unzip args_w_offsets
cmm_args <- mapM getArgAmode args -- No void args
- --pprTraceM "allocDynClosure" (text (show callStack))
allocDynClosureCmm mb_id info_tbl lf_info
use_cc _blame_cc (zip cmm_args offsets)
@@ -106,7 +104,6 @@ allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
-- SAY WHAT WE ARE ABOUT TO DO
let rep = cit_rep info_tbl
tickyDynAlloc mb_id rep lf_info
- --pprTraceM "allocHeapClosure" (ppr info_tbl)
let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))
allocHeapClosure rep info_ptr use_cc amodes_w_offsets
@@ -132,7 +129,6 @@ allocHeapClosure rep info_ptr use_cc payload = do
base <- getHpRelOffset info_offset
emitComment $ mkFastString "allocHeapClosure"
- --pprTraceM "allocHeapClosure" (ppr info_ptr)
emitSetDynHdr base info_ptr use_cc
-- Fill in the fields
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -54,7 +54,6 @@ module GHC.StgToCmm.Monad (
-- more localised access to monad state
CgIdInfo(..),
getBinds, setBinds,
- withEnclosingSpan, getEnclosingSpan,
getUsedInfo, addUsedInfo,
-- out of general friendliness, we also export ...
CgInfoDownwards(..), CgState(..) -- non-abstract
@@ -81,7 +80,6 @@ import GHC.Types.Unique.Supply
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Misc
-import GHC.Types.SrcLoc
import Control.Monad
import Data.List
@@ -168,8 +166,7 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
-- as local jumps? See Note
-- [Self-recursive tail calls] in
-- GHC.StgToCmm.Expr
- cgd_tick_scope:: CmmTickScope, -- Tick scope for new blocks & ticks
- cgd_enclosing_span :: Maybe (RealSrcSpan, String) --
+ cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks
}
type CgBindings = IdEnv CgIdInfo
@@ -284,8 +281,7 @@ initCgInfoDown dflags mod
, cgd_ticky = mkTopTickyCtrLabel
, cgd_sequel = initSequel
, cgd_self_loop = Nothing
- , cgd_tick_scope= GlobalScope
- , cgd_enclosing_span = Nothing }
+ , cgd_tick_scope= GlobalScope }
initSequel :: Sequel
initSequel = Return
@@ -469,13 +465,6 @@ newUnique = do
setState $ state { cgs_uniqs = us' }
return u
-------------------
-withEnclosingSpan :: RealSrcSpan -> String -> FCode a -> FCode a
-withEnclosingSpan ss s (FCode f)= FCode $ \info_down st -> f (info_down { cgd_enclosing_span = Just (ss, s) }) st
-
-getEnclosingSpan :: FCode (Maybe (RealSrcSpan, String))
-getEnclosingSpan = FCode $ \info_down st -> (cgd_enclosing_span info_down, st)
-
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
=====================================
utils/check-api-annotations/check-api-annotations.cabal
=====================================
@@ -20,7 +20,7 @@ Executable check-api-annotations
Main-Is: Main.hs
- Ghc-Options: -Wall -g3 -ddump-cmm -ddump-stg -fforce-recomp
+ Ghc-Options: -Wall
Build-Depends: base >= 4 && < 5,
containers,
=====================================
utils/check-ppr/check-ppr.cabal
=====================================
@@ -20,7 +20,7 @@ Executable check-ppr
Main-Is: Main.hs
- Ghc-Options: -Wall -g3
+ Ghc-Options: -Wall
Build-Depends: base >= 4 && < 5,
bytestring,
=====================================
utils/ghc-pkg/ghc-pkg.cabal
=====================================
@@ -23,7 +23,6 @@ Flag terminfo
Executable ghc-pkg
Default-Language: Haskell2010
Main-Is: Main.hs
- ghc-options: -g3
Other-Extensions: CPP
Build-Depends: base >= 4 && < 5,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d22d5e495a7749a92f05404e07ec2c7fdcde38f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d22d5e495a7749a92f05404e07ec2c7fdcde38f
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/20200608/dc2da637/attachment-0001.html>
More information about the ghc-commits
mailing list