summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgHpc.hs6
-rw-r--r--compiler/codeGen/CgInfoTbls.hs6
-rw-r--r--compiler/codeGen/CgMonad.lhs2
-rw-r--r--compiler/codeGen/CgUtils.hs14
-rw-r--r--compiler/codeGen/ClosureInfo.lhs22
-rw-r--r--compiler/codeGen/CodeGen.lhs4
-rw-r--r--compiler/codeGen/StgCmm.hs4
-rw-r--r--compiler/codeGen/StgCmmClosure.hs23
-rw-r--r--compiler/codeGen/StgCmmExpr.hs21
-rw-r--r--compiler/codeGen/StgCmmHpc.hs11
-rw-r--r--compiler/codeGen/StgCmmLayout.hs2
-rw-r--r--compiler/codeGen/StgCmmMonad.hs2
-rw-r--r--compiler/codeGen/StgCmmPrim.hs12
-rw-r--r--compiler/codeGen/StgCmmUtils.hs14
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) }
-------------------------------------------------------------------------