summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/TyCon.hs4
-rw-r--r--compiler/GHC/CoreToByteCode.hs70
-rw-r--r--compiler/GHC/Stg/Lift/Analysis.hs2
-rw-r--r--compiler/GHC/StgToCmm/ArgRep.hs53
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs10
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs7
6 files changed, 81 insertions, 65 deletions
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index 9982436429..b82dd5cb26 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -1440,12 +1440,12 @@ data PrimRep
| Int8Rep -- ^ Signed, 8-bit value
| Int16Rep -- ^ Signed, 16-bit value
| Int32Rep -- ^ Signed, 32-bit value
- | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only)
+ | Int64Rep -- ^ Signed, 64 bit value
| IntRep -- ^ Signed, word-sized value
| Word8Rep -- ^ Unsigned, 8 bit value
| Word16Rep -- ^ Unsigned, 16 bit value
| Word32Rep -- ^ Unsigned, 32 bit value
- | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only)
+ | Word64Rep -- ^ Unsigned, 64 bit value
| WordRep -- ^ Unsigned, word-sized value
| AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')
| FloatRep
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index 96c7ea9dec..e993688db9 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/CoreToByteCode.hs
@@ -403,7 +403,7 @@ schemeR_wrk fvs nm original_body (args, body)
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
-- make the arg bitmap
- bits = argBits platform (reverse (map bcIdArgRep all_args))
+ bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
bitmap_size = genericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -508,13 +508,17 @@ schemeE d s p e
-- Delegate tail-calls to schemeT.
schemeE d s p e@(AnnApp _ _) = schemeT d s p e
-schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
+schemeE d s p e@(AnnLit lit) = do
+ platform <- profilePlatform <$> getProfile
+ returnUnboxedAtom d s p e (typeArgRep platform (literalType lit))
schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
schemeE d s p e@(AnnVar v)
-- See Note [Not-necessarily-lifted join points], step 3.
| isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
- | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
+ | isUnliftedType (idType v) = do
+ platform <- profilePlatform <$> getProfile
+ returnUnboxedAtom d s p e (bcIdArgRep platform v)
| otherwise = schemeT d s p e
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
@@ -830,18 +834,19 @@ schemeT d s p app
-- Case 2: Constructor application
| Just con <- maybe_saturated_dcon
, isUnboxedTupleDataCon con
- = case args_r_to_l of
- [arg1,arg2] | isVAtom arg1 ->
+ = do
+ platform <- profilePlatform <$> getProfile
+ case args_r_to_l of
+ [arg1,arg2] | isVAtom platform arg1 ->
unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVAtom arg2 ->
+ [arg1,arg2] | isVAtom platform arg2 ->
unboxedTupleReturn d s p arg1
_other -> multiValException
-- Case 3: Ordinary data constructor
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- profilePlatform <$> getProfile
return (alloc_con `appOL`
mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`
ENTER)
@@ -922,7 +927,9 @@ mkConAppCode orig_d _ p con args_r_to_l =
unboxedTupleReturn
:: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
+unboxedTupleReturn d s p arg = do
+ platform <- profilePlatform <$> getProfile
+ returnUnboxedAtom d s p arg (atomRep platform arg)
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
@@ -934,13 +941,14 @@ doTailCall
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
-doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
+doTailCall init_d s p fn args = do
+ platform <- profilePlatform <$> getProfile
+ do_pushes init_d args (map (atomRep platform) args)
where
do_pushes !d [] reps = do
ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- profilePlatform <$> getProfile
ASSERT( sz == wordSize platform ) return ()
let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
return (push_fn `appOL` (slide `appOL` unitOL ENTER))
@@ -948,8 +956,7 @@ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
let (push_apply, n, rest_of_reps) = findPushSeq reps
(these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- profilePlatform <$> getProfile
instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
-- ^^^ for the PUSH_APPLY_ instruction
return (push_code `appOL` (push_apply `consOL` instrs))
@@ -1137,8 +1144,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- NB: unboxed tuple cases bind the scrut binder to the same offset
-- as one of the alt binders, so we have to remove any duplicates here:
rel_slots = nub $ map fromIntegral $ concatMap spread binds
- spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
- | otherwise = []
+ spread (id, offset) | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]
+ | otherwise = []
where rel_offset = trunc16W $ bytesToWords platform (d - offset)
alt_stuff <- mapM codeAlt alts
@@ -1157,7 +1164,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
alt_bco' <- emitBc alt_bco
let push_alts
| isAlgCase = PUSH_ALTS alt_bco'
- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep platform bndr_ty)
return (push_alts `consOL` scrut_code)
@@ -1374,7 +1381,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- slide and return
d_after_r_min_s = bytesToWords platform (d_after_r - s)
wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
- `snocOL` RETURN_UBX (toArgRep r_rep)
+ `snocOL` RETURN_UBX (toArgRep platform r_rep)
--trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
return (
push_args `appOL`
@@ -1854,13 +1861,13 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe = Map.lookup
idSizeW :: Platform -> Id -> WordOff
-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep
+idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep
-bcIdArgRep :: Id -> ArgRep
-bcIdArgRep = toArgRep . bcIdPrimRep
+bcIdArgRep :: Platform -> Id -> ArgRep
+bcIdArgRep platform = toArgRep platform . bcIdPrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep id
@@ -1870,7 +1877,7 @@ bcIdPrimRep id
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
repSizeWords :: Platform -> PrimRep -> WordOff
-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)
+repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True
@@ -1957,11 +1964,12 @@ bcViewLoop e =
Nothing -> e
Just e' -> bcViewLoop e'
-isVAtom :: AnnExpr' Var ann -> Bool
-isVAtom e | Just e' <- bcView e = isVAtom e'
-isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
-isVAtom (AnnCoercion {}) = True
-isVAtom _ = False
+isVAtom :: Platform -> AnnExpr' Var ann -> Bool
+isVAtom platform expr = case expr of
+ e | Just e' <- bcView e -> isVAtom platform e'
+ (AnnVar v) -> isVoidArg (bcIdArgRep platform v)
+ (AnnCoercion {}) -> True
+ _ -> False
atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
@@ -1976,8 +1984,8 @@ atomPrimRep (AnnCase _ _ ty _) =
atomPrimRep (AnnCoercion {}) = VoidRep
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
-atomRep :: AnnExpr' Id ann -> ArgRep
-atomRep e = toArgRep (atomPrimRep e)
+atomRep :: Platform -> AnnExpr' Id ann -> ArgRep
+atomRep platform e = toArgRep platform (atomPrimRep e)
-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
-- has initial depth @original_depth@. Return the values which the stack
@@ -1985,8 +1993,8 @@ atomRep e = toArgRep (atomPrimRep e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
-typeArgRep :: Type -> ArgRep
-typeArgRep = toArgRep . typePrimRep1
+typeArgRep :: Platform -> Type -> ArgRep
+typeArgRep platform = toArgRep platform . typePrimRep1
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index def06c6102..5aef95c008 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -497,7 +497,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla
idClosureFootprint:: Platform -> Id -> WordOff
idClosureFootprint platform
= StgToCmm.ArgRep.argRepSizeW platform
- . StgToCmm.ArgRep.idArgRep
+ . StgToCmm.ArgRep.idArgRep platform
-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
-- as a result of lifting @f@ to top-level. If there was any growing closure
diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs
index 4d85d23d17..8fc1796d6f 100644
--- a/compiler/GHC/StgToCmm/ArgRep.hs
+++ b/compiler/GHC/StgToCmm/ArgRep.hs
@@ -65,28 +65,33 @@ argRepString V16 = "V16"
argRepString V32 = "V32"
argRepString V64 = "V64"
-toArgRep :: PrimRep -> ArgRep
-toArgRep VoidRep = V
-toArgRep LiftedRep = P
-toArgRep UnliftedRep = P
-toArgRep IntRep = N
-toArgRep WordRep = N
-toArgRep Int8Rep = N -- Gets widened to native word width for calls
-toArgRep Word8Rep = N -- Gets widened to native word width for calls
-toArgRep Int16Rep = N -- Gets widened to native word width for calls
-toArgRep Word16Rep = N -- Gets widened to native word width for calls
-toArgRep Int32Rep = N -- Gets widened to native word width for calls
-toArgRep Word32Rep = N -- Gets widened to native word width for calls
-toArgRep AddrRep = N
-toArgRep Int64Rep = L
-toArgRep Word64Rep = L
-toArgRep FloatRep = F
-toArgRep DoubleRep = D
-toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of
- 16 -> V16
- 32 -> V32
- 64 -> V64
- _ -> error "toArgRep: bad vector primrep"
+toArgRep :: Platform -> PrimRep -> ArgRep
+toArgRep platform rep = case rep of
+ VoidRep -> V
+ LiftedRep -> P
+ UnliftedRep -> P
+ IntRep -> N
+ WordRep -> N
+ Int8Rep -> N -- Gets widened to native word width for calls
+ Word8Rep -> N -- Gets widened to native word width for calls
+ Int16Rep -> N -- Gets widened to native word width for calls
+ Word16Rep -> N -- Gets widened to native word width for calls
+ Int32Rep -> N -- Gets widened to native word width for calls
+ Word32Rep -> N -- Gets widened to native word width for calls
+ AddrRep -> N
+ Int64Rep -> case platformWordSize platform of
+ PW4 -> L
+ PW8 -> N
+ Word64Rep -> case platformWordSize platform of
+ PW4 -> L
+ PW8 -> N
+ FloatRep -> F
+ DoubleRep -> D
+ (VecRep len elem) -> case len*primElemRepSizeB elem of
+ 16 -> V16
+ 32 -> V32
+ 64 -> V64
+ _ -> error "toArgRep: bad vector primrep"
isNonV :: ArgRep -> Bool
isNonV V = False
@@ -106,8 +111,8 @@ argRepSizeW platform = \case
where
ws = platformWordSizeInBytes platform
-idArgRep :: Id -> ArgRep
-idArgRep = toArgRep . idPrimRep
+idArgRep :: Platform -> Id -> ArgRep
+idArgRep platform = toArgRep platform . idPrimRep
-- This list of argument patterns should be kept in sync with at least
-- the following:
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index 70a9fc8fe7..88e77b3782 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -321,12 +321,14 @@ direct_call caller call_conv lbl arity args
-- using zeroCLit or even undefined would work, but would be ugly).
--
getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
-getArgRepsAmodes = mapM getArgRepAmode
- where getArgRepAmode arg
+getArgRepsAmodes args = do
+ platform <- profilePlatform <$> getProfile
+ mapM (getArgRepAmode platform) args
+ where getArgRepAmode platform arg
| V <- rep = return (V, Nothing)
| otherwise = do expr <- getArgAmode (NonVoid arg)
return (rep, Just expr)
- where rep = toArgRep (argPrimRep arg)
+ where rep = toArgRep platform (argPrimRep arg)
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [] = []
@@ -542,7 +544,7 @@ mkVirtConstrSizes profile field_reps
mkArgDescr :: Platform -> [Id] -> ArgDescr
mkArgDescr platform args
= let arg_bits = argBits platform arg_reps
- arg_reps = filter isNonV (map idArgRep args)
+ arg_reps = filter isNonV (map (idArgRep platform) args)
-- Getting rid of voids eases matching of standard patterns
in case stdPattern arg_reps of
Just spec_id -> ArgSpec spec_id
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index b7f43665cd..44a99a0cae 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -409,10 +409,11 @@ tickySlowCall lf_info args = do
tickySlowCallPat (map argPrimRep args)
tickySlowCallPat :: [PrimRep] -> FCode ()
-tickySlowCallPat args = ifTicky $
- let argReps = map toArgRep args
+tickySlowCallPat args = ifTicky $ do
+ platform <- profilePlatform <$> getProfile
+ let argReps = map (toArgRep platform) args
(_, n_matched) = slowCallPattern argReps
- in if n_matched > 0 && args `lengthIs` n_matched
+ if n_matched > 0 && args `lengthIs` n_matched
then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
View Lorry Controller Status