diff options
Diffstat (limited to 'compiler/codeGen')
-rw-r--r-- | compiler/codeGen/CgHpc.hs | 6 | ||||
-rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 6 | ||||
-rw-r--r-- | compiler/codeGen/CgMonad.lhs | 2 | ||||
-rw-r--r-- | compiler/codeGen/CgUtils.hs | 14 | ||||
-rw-r--r-- | compiler/codeGen/ClosureInfo.lhs | 22 | ||||
-rw-r--r-- | compiler/codeGen/CodeGen.lhs | 4 | ||||
-rw-r--r-- | compiler/codeGen/StgCmm.hs | 4 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 23 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 21 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmHpc.hs | 11 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 2 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 2 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 12 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 14 |
14 files changed, 98 insertions, 45 deletions
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 48756505c3..a134f00067 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -12,6 +12,7 @@ import OldCmm import CLabel import Module import OldCmmUtils +import CgUtils import CgMonad import HscTypes @@ -30,9 +31,8 @@ cgTickBox mod n = do hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) + emitDataLits (mkHpcTicksLabel this_mod) $ + [ CmmInt 0 W64 | _ <- take hpc_tickCount [0::Int ..] ] diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 2745832227..093b9ffaab 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -84,12 +84,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (closureInfoLocal cl_info) False prof cl_type info) where info = case lf_info of @@ -142,7 +142,7 @@ emitReturnTarget name stmts ; let info = CmmInfo gc_target Nothing - (CmmInfoTable False + (CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 9b195bfab2..273c1bf16e 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -736,7 +736,7 @@ emitCgStmt stmt ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } } -emitData :: Section -> [CmmStatic] -> Code +emitData :: Section -> CmmStatics -> Code emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 63d99a629f..effa7a42d6 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -545,26 +545,26 @@ baseRegOffset _ = panic "baseRegOffset:other" emitDataLits :: CLabel -> [CmmLit] -> Code -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: String -> CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits caller lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -580,7 +580,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 4f59d95276..daf476adfc 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -50,7 +50,7 @@ module ClosureInfo ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - isStaticClosure, + closureInfoLocal, isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, @@ -111,7 +111,8 @@ data ClosureInfo closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -341,7 +342,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -842,6 +848,9 @@ staticClosureRequired _ _ _ = True %************************************************************************ \begin{code} +closureInfoLocal :: ClosureInfo -> Bool +closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl +closureInfoLocal ConInfo{} = False isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -927,9 +936,9 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name caf + LFThunk{} -> mkInfoTableLabel name caf - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf + LFReEntrant _ _ _ _ -> mkInfoTableLabel name caf _ -> panic "infoTableLabelFromCI" @@ -1003,7 +1012,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" \end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 7a7bf48b92..42c4bd24fc 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -105,7 +105,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] ; whenC (this_mod == mainModIs dflags) $ emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 2bfe1876ba..29a254fafc 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -81,7 +81,7 @@ codeGen dflags this_mod data_tycons -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -182,7 +182,7 @@ mkModuleInit cost_centre_info this_mod hpc_info ; initCostCentres cost_centre_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] } --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index a8d91f58d6..7c4f8bc8b8 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -56,7 +56,7 @@ module StgCmmClosure ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - isStaticClosure, + closureInfoLocal, isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, clHasCafRefs @@ -679,7 +679,8 @@ data ClosureInfo closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) closureDescr :: !String, -- closure description (for profiling) - closureCafs :: !CafInfo -- whether the closure may have CAFs + closureCafs :: !CafInfo, -- whether the closure may have CAFs + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -725,7 +726,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSRT = srt_info, closureType = idType id, closureDescr = descr, - closureCafs = idCafInfo id } + closureCafs = idCafInfo id, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -756,7 +762,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureSRT = NoC_SRT, closureType = ty, closureDescr = "", - closureCafs = cafs } + closureCafs = cafs, + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" @@ -931,6 +938,10 @@ staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con }) GenericRep _ _ _ ConstrNoCaf -> False _other -> True +closureInfoLocal :: ClosureInfo -> Bool +closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl +closureInfoLocal ConInfo{} = False + isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -997,9 +1008,9 @@ infoTableLabelFromCI cl@(ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl _other -> panic "infoTableLabelFromCI" diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index eee4a08bc7..fa16b2a7f5 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -53,6 +53,11 @@ import UniqSupply cgExpr :: StgExpr -> FCode () cgExpr (StgApp fun args) = cgIdApp fun args + +{- seq# a s ==> a -} +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = + cgIdApp a [] + cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr } @@ -322,6 +327,22 @@ cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ ; emit $ mkComment $ mkFastString "should be unreachable code" ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} +{- +case seq# a s of v + (# s', a' #) -> e + +==> + +case a of v + (# s', a' #) -> e + +(taking advantage of the fact that the return convention for (# State#, a #) +is the same as the return convention for just 'a') +-} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts + = -- handle seq#, same return convention as vanilla 'a'. + cgCase (StgApp a []) bndr srt alt_type alts + cgCase scrut bndr srt alt_type alts = -- the general case do { up_hp_usg <- getVirtHp -- Upstream heap usage diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index fae3bef016..4465e30b04 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -11,11 +11,11 @@ module StgCmmHpc ( initHpc, mkTickBox ) where import StgCmmMonad import MkGraph -import CmmDecl import CmmExpr import CLabel import Module import CmmUtils +import StgCmmUtils import HscTypes import StaticFlags @@ -36,9 +36,8 @@ initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = whenC opt_Hpc $ - do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] + do { emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0::Int ..] + ] } diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index eddf257e5f..278c41aef2 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -496,7 +496,7 @@ mkCmmInfo cl_info ad_lit <- mkStringCLit (closureValDescr cl_info) return $ ProfilingInfo fd_lit ad_lit else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - ; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) } + ; return (CmmInfoTable (closureInfoLocal cl_info) (isStaticClosure cl_info) prof cl_type info) } where k_with_con_name con_info con info_lbl = do cstr <- mkByteStringCLit $ dataConIdentity con diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index f92b3cde27..d06b581f26 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -593,7 +593,7 @@ emit ag = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } -emitData :: Section -> [CmmStatic] -> FCode () +emitData :: Section -> CmmStatics -> FCode () emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 1a6d05e6e6..c71d285735 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -210,6 +210,18 @@ emitPrimOp [res] ParOp [arg] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] +emitPrimOp [res] SparkOp [arg] + = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + emitCCall + [] + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + emitPrimOp [res] ReadMutVarOp [mutv] = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 558b7fdeaa..74da7317d4 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -508,26 +508,26 @@ baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) emitDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block emitRODataLits lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -543,7 +543,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- |