diff options
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 39 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Env.hs | 70 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Utils/Trace.hs | 1 | ||||
-rw-r--r-- | compiler/MachDeps.h | 119 |
9 files changed, 208 insertions, 49 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 96d4df976a..8cee6d0021 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -3016,8 +3016,6 @@ simplAlts env0 scrut case_bndr alts cont' ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ - -- ; (alt_floats,alts'') <- doAlts alt_env' case_bndr' alts' - ; let alts_ty' = contResultType cont' ; final_case <- mkCase (seDynFlags env0) alt_env' scrut' case_bndr' alts_ty' alts' diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 75b851e6a8..b525189cea 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -86,6 +86,9 @@ import GHC.Core.Make ( mkCoreApps, mkCoreLams ) import GHC.Data.TrieMap (elemsTM) import GHC.Core.Stats (exprSize) import GHC.Utils.Constants (debugIsOn) +import GHC.Types.Id.Make (voidArgId, voidPrimId) +import GHC.Types.RepType (isVoidTy) +import GHC.Builtin.Types (unboxedUnitTy) {- ************************************************************************ @@ -2142,7 +2145,6 @@ prepareAlts scrut case_bndr' alts -- i.e. the constructors that can't match the default case ; when yes2 $ tick (FillInCaseDefault case_bndr') ; when yes3 $ tick (AltMerge case_bndr') - -- ; doAlts case_bndr' alts ; return (idcs3, alts3) } | otherwise -- Not a data type, so nothing interesting happens @@ -2499,15 +2501,32 @@ doAlts env case_bndr alts_in = do -- There are alts to combine, create a join point representing the rhs. | (alt1@Alt{alt_bndrs = alt1_bndrs, alt_rhs = alt1_rhs}:_) <- combined_in = do - let -- Binders the join point might close over. + let --shared_bnds = case_bndr:alt1_bndrs + -- -- FVs of the rhs + -- fvs = exprFreeVars (alt1_rhs) + -- -- Which of the binders do we *actually* close over. + -- used_shared = map (`elemVarSet` fvs) shared_bnds :: [Bool] + + -- rhs_args = filterByList used_shared shared_bnds + -- alt_args alt = filterByList used_shared (map Var (case_bndr : alt_bndrs alt)) + -- shared_rhs_expr = -- pprTraceIt "shared_rhs" $ + -- mkCoreLams rhs_args (alt1_rhs) + -- arity = length rhs_args + + + -- Binders the join point might close over. shared_bnds = case_bndr:alt1_bndrs - -- FVs of the rhs - fvs = exprFreeVars (alt1_rhs) - -- Which of the binders do we *actually* close over. - used_shared = map (`elemVarSet` fvs) shared_bnds :: [Bool] - rhs_args = filterByList used_shared shared_bnds - alt_args alt = filterByList used_shared (map Var (case_bndr : alt_bndrs alt)) + -- FVs of the rhs which are the case binder or bound by a constructor. + let case_bound_fvs = filter (`elem` shared_bnds) $ exprFreeVarsList (alt1_rhs) + + rhs_args = case_bound_fvs + alt_args alt = + let shared_bnds_a = case_bndr:(alt_bndrs alt) + -- This seems a bit expensive. + alt_bound_fvs = filter (`elem` shared_bnds_a) $ exprFreeVarsList (alt_rhs alt) + alt_call_args = alt_bound_fvs + in map Var alt_call_args shared_rhs_expr = -- pprTraceIt "shared_rhs" $ mkCoreLams rhs_args (alt1_rhs) arity = length rhs_args @@ -2533,7 +2552,7 @@ doAlts env case_bndr alts_in = do pprTraceM "combined_alts" ( text "alt_count:" <> ppr (length new_alts) $$ text "alt_size:" <> ppr (exprSize alt1_rhs) $$ text "alt_elim:" <> ppr ((length new_alts - 1) * exprSize alt1_rhs) $$ - text "used_vars:" <> ppr (used_shared) $$ + text "used_vars:" <> ppr (case_bound_fvs) $$ text "alt_args1" <> ppr (alt_args alt1) $$ text "old_rhs:" <> ppr alt1_rhs $$ @@ -2559,7 +2578,7 @@ doAlts env case_bndr alts_in = do -- Adds one alternative to the map extendMap :: CoreMap [CoreAlt] -> CoreAlt -> CoreMap [CoreAlt] - extendMap m alt = alterTM (mkCoreLams (alt_bndrs alt) (alt_rhs alt)) update m + extendMap m alt = alterTM ((alt_rhs alt)) update m where update Nothing = Just [alt] update (Just cs) = Just (alt:cs) diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index c2287916db..a88f3d8d45 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -377,8 +377,8 @@ We use the state-token type which generates no code. -} mkWorkerArgs :: Id -- The wrapper Id - -> Bool - -> [Var] + -> Bool -- Allows fun-to-thunk + -> [Var] -- Args -> Type -- Type of body -> ([Var], -- Lambda bound args [Var]) -- Args at call site diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 7d89b71309..9e3921a875 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -62,6 +62,7 @@ import GHC.Data.FastString import GHC.Data.List.SetOps import Control.Monad +import GHC.Utils.Panic.Plain (assert, assertM) ------------------------------------------------------------------------ -- Top-level bindings @@ -479,6 +480,7 @@ closureCodeBody top_lvl bndr cl_info cc [] body fv_details lf_info = closureLFInfo cl_info info_tbl = mkCmmInfo cl_info bndr cc +-- A function. closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details = let nv_args = nonVoidIds args arity = length args @@ -539,8 +541,11 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) 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 (id, off) = do { reg <- rebindToReg id; return (reg, off) } +bind_fv :: HasCallStack => (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff) +bind_fv (id, off) = do { massertPpr (not (isJoinId (fromNonVoid id))) + (text "Re-Binding join id to register:" <> ppr id $$ + text "Is a join point being used inside a thunk?") + ; reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 3ff745a719..1a327ca20d 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -498,9 +498,12 @@ data CallOpts = CallOpts , co_ticky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) } +call_platform :: CallOpts -> Platform +call_platform = profilePlatform . co_profile + getCallMethod :: CallOpts -> Name -- Function being applied - -> Id -- Function Id used to chech if it can refer to + -> Id -- Function Id used to check if it can refer to -- CAF's and whether the function is tail-calling -- itself -> LambdaFormInfo -- Its info @@ -587,7 +590,7 @@ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs -getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" +getCallMethod opts _ id lf_info _ _ cg_loc _ = pprPanic "Unknown call method" (ppr id <+> ppr lf_info <+> pdoc (call_platform opts) cg_loc) ----------------------------------------------------------------------------- -- Data types for closure information diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index f28f0d0ec2..3c9e948f1c 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -45,6 +45,8 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Driver.Session +import GHC.Utils.Trace +import GHC.Stack.Types (HasCallStack) ------------------------------------- @@ -74,7 +76,7 @@ lneIdInfo platform id regs rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info - = do platform <- getPlatform + = do platform <- targetPlatform <$> getDynFlags reg <- newTemp (gcWord platform) return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) @@ -105,9 +107,11 @@ maybeLetNoEscape _other = Nothing -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. --------------------------------------------------------- -addBindC :: CgIdInfo -> FCode () +addBindC :: HasCallStack => CgIdInfo -> FCode () addBindC stuff_to_bind = do binds <- getBinds + p <- targetPlatform <$> getDynFlags + pprTraceM "addBind" (pdoc p stuff_to_bind <+> traceCallStackDoc) setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind addBindsC :: [CgIdInfo] -> FCode () @@ -120,30 +124,34 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { platform <- targetPlatform <$> getDynFlags - ; local_binds <- getBinds -- Try local bindings first - ; case lookupVarEnv local_binds id of { - Just info -> return info ; - Nothing -> do { - - -- Should be imported; make up a CgIdInfo for it - let name = idName id - ; if isExternalName name then - let ext_lbl - | isBoxedType (idType id) - = mkClosureLabel name $ idCafInfo id - | isUnliftedType (idType id) - -- An unlifted external Id must refer to a top-level - -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel". - = assert (idType id `eqType` addrPrimTy) $ - mkBytesLabel name - | otherwise - = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) - in return $ - litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) - else - cgLookupPanic id -- Bug - }}} + = do + r <- do { platform <- targetPlatform <$> getDynFlags + ; local_binds <- getBinds -- Try local bindings first + ; case lookupVarEnv local_binds id of { + Just info -> return info ; + Nothing -> do { + + -- Should be imported; make up a CgIdInfo for it + let name = idName id + ; if isExternalName name then + let ext_lbl + | isBoxedType (idType id) + = mkClosureLabel name $ idCafInfo id + | isUnliftedType (idType id) + -- An unlifted external Id must refer to a top-level + -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel". + = assert (idType id `eqType` addrPrimTy) $ + mkBytesLabel name + | otherwise + = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) + in return $ + litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) + else + cgLookupPanic id -- Bug + }}} + p <- targetPlatform <$> getDynFlags + pprTraceM "getCgInfo" (ppr id <+> pdoc p r) + return r cgLookupPanic :: Id -> FCode a cgLookupPanic id @@ -160,7 +168,7 @@ cgLookupPanic id -- 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 @@ -168,20 +176,20 @@ bindToReg nvid@(NonVoid id) lf_info 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 +idToReg :: HasCallStack => Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 6355b55427..dbf93023c5 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -56,6 +56,8 @@ import GHC.Utils.Panic.Plain import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List ( partition ) +import GHC.Utils.Trace (pprTraceM) +import GHC.Platform.Profile (Profile(profilePlatform)) ------------------------------------------------------------------------ -- cgExpr: the main function @@ -153,12 +155,15 @@ cgLneBinds :: BlockId -> CgStgBinding -> FCode () cgLneBinds join_id (StgNonRec bndr rhs) = do { local_cc <- saveCurrentCostCentre -- See Note [Saving the current cost centre] + ; pprTraceM "cgLneBinds" (ppr bndr) ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs ; fcode ; addBindC info } cgLneBinds join_id (StgRec pairs) = do { local_cc <- saveCurrentCostCentre + ; pprTraceM "cgLneBinds" (ppr $ map fst pairs) + ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs ; let (infos, fcodes) = unzip r ; addBindsC infos @@ -897,6 +902,7 @@ cgIdApp fun_id args = do lf_info = cg_lf fun_info n_args = length args v_args = length $ filter (isVoidTy . stgArgType) args + pprTraceM "fun_info" (ppr fun_id <+> pdoc (profilePlatform profile) fun_info) case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. ReturnIt diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs index 5da6e6e5d9..3fff023d39 100644 --- a/compiler/GHC/Utils/Trace.hs +++ b/compiler/GHC/Utils/Trace.hs @@ -9,6 +9,7 @@ module GHC.Utils.Trace , warnPprTrace , pprTraceUserWarning , trace + , traceCallStackDoc ) where diff --git a/compiler/MachDeps.h b/compiler/MachDeps.h new file mode 100644 index 0000000000..98a90814d9 --- /dev/null +++ b/compiler/MachDeps.h @@ -0,0 +1,119 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2002 + * + * Definitions that characterise machine specific properties of basic + * types (C & Haskell) of a target platform. + * + * NB: Keep in sync with HsFFI.h and StgTypes.h. + * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE! + * + * To understand the structure of the RTS headers, see the wiki: + * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +/* Don't allow stage1 (cross-)compiler embed assumptions about target + * platform. When ghc-stage1 is being built by ghc-stage0 is should not + * refer to target defines. A few past examples: + * - https://gitlab.haskell.org/ghc/ghc/issues/13491 + * - https://phabricator.haskell.org/D3122 + * - https://phabricator.haskell.org/D3405 + * + * In those cases code change assumed target defines like SIZEOF_HSINT + * are applied to host platform, not target platform. + * + * So what should be used instead in GHC_STAGE=1? + * + * To get host's equivalent of SIZEOF_HSINT you can use Bits instances: + * Data.Bits.finiteBitSize (0 :: Int) + * + * To get target's values it is preferred to use runtime target + * configuration from 'targetPlatform :: DynFlags -> Platform' + * record. + * + * Hence we hide these macros from GHC_STAGE=1 + */ + +/* Sizes of C types come from here... */ +#include "ghcautoconf.h" + +/* Sizes of Haskell types follow. These sizes correspond to: + * - the number of bytes in the primitive type (eg. Int#) + * - the number of bytes in the external representation (eg. HsInt) + * - the scale offset used by writeFooOffAddr# + * + * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1, + * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap. + */ + +#define SIZEOF_HSCHAR SIZEOF_WORD32 +#define ALIGNMENT_HSCHAR ALIGNMENT_WORD32 + +#define SIZEOF_HSINT SIZEOF_VOID_P +#define ALIGNMENT_HSINT ALIGNMENT_VOID_P + +#define SIZEOF_HSWORD SIZEOF_VOID_P +#define ALIGNMENT_HSWORD ALIGNMENT_VOID_P + +#define SIZEOF_HSDOUBLE SIZEOF_DOUBLE +#define ALIGNMENT_HSDOUBLE ALIGNMENT_DOUBLE + +#define SIZEOF_HSFLOAT SIZEOF_FLOAT +#define ALIGNMENT_HSFLOAT ALIGNMENT_FLOAT + +#define SIZEOF_HSPTR SIZEOF_VOID_P +#define ALIGNMENT_HSPTR ALIGNMENT_VOID_P + +#define SIZEOF_HSFUNPTR SIZEOF_VOID_P +#define ALIGNMENT_HSFUNPTR ALIGNMENT_VOID_P + +#define SIZEOF_HSSTABLEPTR SIZEOF_VOID_P +#define ALIGNMENT_HSSTABLEPTR ALIGNMENT_VOID_P + +#define SIZEOF_INT8 SIZEOF_INT8_T +#define ALIGNMENT_INT8 ALIGNMENT_INT8_T + +#define SIZEOF_WORD8 SIZEOF_UINT8_T +#define ALIGNMENT_WORD8 ALIGNMENT_UINT8_T + +#define SIZEOF_INT16 SIZEOF_INT16_T +#define ALIGNMENT_INT16 ALIGNMENT_INT16_T + +#define SIZEOF_WORD16 SIZEOF_UINT16_T +#define ALIGNMENT_WORD16 ALIGNMENT_UINT16_T + +#define SIZEOF_INT32 SIZEOF_INT32_T +#define ALIGNMENT_INT32 ALIGNMENT_INT32_T + +#define SIZEOF_WORD32 SIZEOF_UINT32_T +#define ALIGNMENT_WORD32 ALIGNMENT_UINT32_T + +#define SIZEOF_INT64 SIZEOF_INT64_T +#define ALIGNMENT_INT64 ALIGNMENT_INT64_T + +#define SIZEOF_WORD64 SIZEOF_UINT64_T +#define ALIGNMENT_WORD64 ALIGNMENT_UINT64_T + +#if !defined(WORD_SIZE_IN_BITS) +#if SIZEOF_HSWORD == 4 +#define WORD_SIZE_IN_BITS 32 +#define WORD_SIZE_IN_BITS_FLOAT 32.0 +#else +#define WORD_SIZE_IN_BITS 64 +#define WORD_SIZE_IN_BITS_FLOAT 64.0 +#endif +#endif + +#if !defined(TAG_BITS) +#if SIZEOF_HSWORD == 4 +#define TAG_BITS 2 +#else +#define TAG_BITS 3 +#endif +#endif + +#define TAG_MASK ((1 << TAG_BITS) - 1) + |