Commit 0de03cd7 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

DynFlags refactoring III

Use Platform instead of DynFlags when possible:
* `tARGET_MIN_INT` et al. replaced with `platformMinInt` et al.
* no more DynFlags in PreRules: added a new `RuleOpts` datatype
* don't use `wORD_SIZE` in the compiler
* make `wordAlignment` use `Platform`
* make `dOUBLE_SIZE` a constant

Metric Decrease:
    T13035
    T1969
parent 262e42aa
......@@ -96,7 +96,7 @@ assembleBCOs
-> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
bcos <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos
(bcos',ptrs) <- mallocStrings hsc_env bcos
return CompiledByteCode
{ bc_bcos = bcos'
......@@ -151,20 +151,19 @@ mallocStrings hsc_env ulbcos = do
assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO hsc_env pbco = do
ubco <- assembleBCO (hsc_dflags hsc_env) pbco
ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco
([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
return ubco'
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO { protoBCOName = nm
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO platform (ProtoBCO { protoBCOName = nm
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity }) = do
-- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI dflags) instrs
let asm = mapM_ (assembleI platform) instrs
platform = targetPlatform dflags
initial_offset = 0
-- Jump instructions are variable-sized, there are long and short variants
......@@ -347,10 +346,10 @@ largeArg16s platform = case platformWordSize platform of
PW8 -> 4
PW4 -> 2
assembleI :: DynFlags
assembleI :: Platform
-> BCInstr
-> Assembler ()
assembleI dflags i = case i of
assembleI platform i = case i of
STKCHECK n -> emit bci_STKCHECK [Op n]
PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1]
PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
......@@ -365,14 +364,14 @@ assembleI dflags i = case i of
emit bci_PUSH_G [Op p]
PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
emit bci_PUSH_G [Op p]
PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto
PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_G [Op p]
PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto
PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_ALTS [Op p]
PUSH_ALTS_UNLIFTED proto pk
-> do let ul_bco = assembleBCO dflags proto
-> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
PUSH_PAD8 -> emit bci_PUSH_PAD8 []
......@@ -443,7 +442,7 @@ assembleI dflags i = case i of
where
literal (LitLabel fs (Just sz) _)
| platformOS (targetPlatform dflags) == OSMinGW32
| platformOS platform == OSMinGW32
= litlabel (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
......@@ -469,9 +468,9 @@ assembleI dflags i = case i of
litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a]
float = words . mkLitF
double = words . mkLitD dflags
double = words . mkLitD platform
int = words . mkLitI
int64 = words . mkLitI64 dflags
int64 = words . mkLitI64 platform
words ws = lit (map BCONPtrWord ws)
word w = words [w]
......@@ -505,8 +504,8 @@ return_ubx V64 = error "return_ubx: vector"
-- bit pattern is correct for the host's word size and endianness.
mkLitI :: Int -> [Word]
mkLitF :: Float -> [Word]
mkLitD :: DynFlags -> Double -> [Word]
mkLitI64 :: DynFlags -> Int64 -> [Word]
mkLitD :: Platform -> Double -> [Word]
mkLitI64 :: Platform -> Int64 -> [Word]
mkLitF f
= runST (do
......@@ -517,9 +516,8 @@ mkLitF f
return [w0 :: Word]
)
mkLitD dflags d
| wORD_SIZE dflags == 4
= runST (do
mkLitD platform d = case platformWordSize platform of
PW4 -> runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 d
d_arr <- castSTUArray arr
......@@ -527,20 +525,16 @@ mkLitD dflags d
w1 <- readArray d_arr 1
return [w0 :: Word, w1]
)
| wORD_SIZE dflags == 8
= runST (do
PW8 -> runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 d
d_arr <- castSTUArray arr
w0 <- readArray d_arr 0
return [w0 :: Word]
)
| otherwise
= panic "mkLitD: Bad wORD_SIZE"
mkLitI64 dflags ii
| wORD_SIZE dflags == 4
= runST (do
mkLitI64 platform ii = case platformWordSize platform of
PW4 -> runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 ii
d_arr <- castSTUArray arr
......@@ -548,16 +542,13 @@ mkLitI64 dflags ii
w1 <- readArray d_arr 1
return [w0 :: Word,w1]
)
| wORD_SIZE dflags == 8
= runST (do
PW8 -> runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 ii
d_arr <- castSTUArray arr
w0 <- readArray d_arr 0
return [w0 :: Word]
)
| otherwise
= panic "mkLitI64: Bad wORD_SIZE"
mkLitI i = [fromIntegral i :: Word]
......
......@@ -88,7 +88,7 @@ lintCmmExpr (CmmLoad expr rep) = do
_ <- lintCmmExpr expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
......@@ -124,10 +124,10 @@ isOffsetOp _ = False
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress _
= return ()
......
......@@ -542,10 +542,11 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
-- closure type, live regs
{% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags
let platform = targetPlatform dflags
live <- sequence $7
let prof = NoProfilingInfo
-- drop one for the info pointer
bitmap = mkLiveness dflags (drop 1 live)
bitmap = mkLiveness platform (drop 1 live)
rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
return (mkCmmRetLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
......@@ -1145,15 +1146,15 @@ reserveStackFrame
-> CmmParse ()
reserveStackFrame psize preg body = do
dflags <- getDynFlags
let platform = targetPlatform dflags
old_updfr_off <- getUpdFrameOff
reg <- preg
esize <- psize
let platform = targetPlatform dflags
let size = case constantFoldExpr platform esize of
CmmLit (CmmInt n _) -> n
_other -> pprPanic "CmmParse: not a compile-time integer: "
(ppr esize)
let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size
emitAssign reg (CmmStackSlot Old frame)
withUpdFrameOff frame body
......@@ -1187,7 +1188,8 @@ foreignCall conv_string results_code expr_code args_code safety ret
expr <- expr_code
args <- sequence args_code
let
expr' = adjCallTarget dflags conv expr args
platform = targetPlatform dflags
expr' = adjCallTarget platform conv expr args
(arg_exprs, arg_hints) = unzip args
(res_regs, res_hints) = unzip results
fc = ForeignConvention conv arg_hints res_hints ret
......@@ -1230,7 +1232,6 @@ doJumpWithStack expr_code stk_code args_code = do
doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-> CmmParse ()
doCall expr_code res_code args_code = do
dflags <- getDynFlags
expr <- expr_code
args <- sequence args_code
ress <- sequence res_code
......@@ -1238,16 +1239,15 @@ doCall expr_code res_code args_code = do
c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
emit c
adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
-> CmmExpr
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args
| platformOS platform == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType platform e)))
where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))
-- c.f. CgForeignCall.emitForeignCall
platform = targetPlatform dflags
adjCallTarget _ _ expr _
= expr
......@@ -1380,7 +1380,8 @@ doSwitch mb_range scrut arms deflt
let table = M.fromList (concat table_entries)
dflags <- getDynFlags
let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
let platform = targetPlatform dflags
let range = fromMaybe (0, platformMaxWord platform) mb_range
expr <- scrut
-- ToDo: check for out of range and jump to default if necessary
......
......@@ -489,13 +489,14 @@ regUsedIn platform = regUsedIn_ where
--
---------------------------------------------
mkLiveness :: DynFlags -> [LocalReg] -> Liveness
mkLiveness :: Platform -> [LocalReg] -> Liveness
mkLiveness _ [] = []
mkLiveness dflags (reg:regs)
= bits ++ mkLiveness dflags regs
mkLiveness platform (reg:regs)
= bits ++ mkLiveness platform regs
where
sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
`quot` wORD_SIZE dflags
word_size = platformWordSizeInBytes platform
sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)
`quot` word_size
-- number of words, rounded up
bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
......
......@@ -2,6 +2,7 @@
module GHC.CmmToAsm.Config
( NCGConfig(..)
, ncgWordWidth
, platformWordWidth
)
where
......@@ -27,6 +28,10 @@ data NCGConfig = NCGConfig
-- | Return Word size
ncgWordWidth :: NCGConfig -> Width
ncgWordWidth config = case platformWordSize (ncgPlatform config) of
ncgWordWidth config = platformWordWidth (ncgPlatform config)
-- | Return Word size
platformWordWidth :: Platform -> Width
platformWordWidth platform = case platformWordSize platform of
PW4 -> W32
PW8 -> W64
......@@ -2185,11 +2185,12 @@ genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _
return $ code_dst dst_r `appOL` code_src src_r `appOL`
go dst_r src_r tmp_r (fromInteger n)
where
platform = targetPlatform dflags
-- The number of instructions we will generate (approx). We need 2
-- instructions per move.
insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
......@@ -2241,7 +2242,8 @@ genCCall' dflags _ (PrimTarget (MO_Memset align)) _
return $ code_dst dst_r `appOL`
go4 dst_r (fromInteger n)
where
maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
platform = targetPlatform dflags
maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
c2 = c `shiftL` 8 .|. c
......@@ -2884,8 +2886,7 @@ genCCall64' :: ForeignTarget -- function to call
-> [CmmActual] -- arguments (of mixed type)
-> NatM InstrBlock
genCCall64' target dest_regs args = do
config <- getConfig
let platform = ncgPlatform config
platform <- getPlatform
-- load up the register arguments
let prom_args = map (maybePromoteCArg platform W32) args
......@@ -3046,7 +3047,7 @@ genCCall64' target dest_regs args = do
-- Align stack to 16n for calls, assuming a starting stack
-- alignment of 16n - word_size on procedure entry. Which we
-- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]
let word_size = platformWordSizeInBytes (ncgPlatform config)
let word_size = platformWordSizeInBytes platform
(real_size, adjust_rsp) <-
if (tot_arg_size + word_size) `rem` 16 == 0
then return (tot_arg_size, nilOL)
......@@ -3097,7 +3098,7 @@ genCCall64' target dest_regs args = do
-- stdcall has callee do it, but is not supported on
-- x86_64 target (see #3336)
(if real_size==0 then [] else
[ADD (intFormat (ncgWordWidth config)) (OpImm (ImmInt real_size)) (OpReg esp)])
[ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])
++
[DELTA (delta + real_size)]
)
......@@ -3276,10 +3277,10 @@ genSwitch expr targets = do
let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
offsetReg <- getNewRegNat (intFormat (ncgWordWidth config))
offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))
return $ if is32bit || os == OSDarwin
then e_code `appOL` t_code `appOL` toOL [
ADD (intFormat (ncgWordWidth config)) op (OpReg tableReg),
ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),
JMP_TBL (OpReg tableReg) ids rosection lbl
]
else -- HACK: On x86_64 binutils<2.17 is only able to generate
......@@ -3290,7 +3291,7 @@ genSwitch expr targets = do
-- PprMach.hs/pprDataItem once binutils 2.17 is standard.
e_code `appOL` t_code `appOL` toOL [
MOVSxL II32 op (OpReg offsetReg),
ADD (intFormat (ncgWordWidth config))
ADD (intFormat (platformWordWidth platform))
(OpReg offsetReg)
(OpReg tableReg),
JMP_TBL (OpReg tableReg) ids rosection lbl
......
......@@ -89,7 +89,7 @@ module GHC.Core (
-- * Core rule data types
CoreRule(..), RuleBase,
RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
RuleEnv(..), mkRuleEnv, emptyRuleEnv,
RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv,
-- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation,
......@@ -100,6 +100,7 @@ module GHC.Core (
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import CostCentre
import VarEnv( InScopeSet )
......@@ -113,7 +114,6 @@ import Literal
import GHC.Core.DataCon
import Module
import BasicTypes
import GHC.Driver.Session
import Outputable
import Util
import UniqSet
......@@ -1384,7 +1384,14 @@ data CoreRule
}
-- See Note [Extra args in rule matching] in GHC.Core.Rules
type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
-- | Rule options
data RuleOpts = RuleOpts
{ roPlatform :: !Platform -- ^ Target platform
, roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding
, roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled
}
type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
type InScopeEnv = (InScopeSet, IdUnfoldingFun)
type IdUnfoldingFun = Id -> Unfolding
......@@ -1963,23 +1970,23 @@ mkTyArg ty
-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
mkIntLit :: DynFlags -> Integer -> Expr b
mkIntLit :: Platform -> Integer -> Expr b
-- | Create a machine integer literal expression of type @Int#@ from an @Int@.
-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
mkIntLitInt :: DynFlags -> Int -> Expr b
mkIntLitInt :: Platform -> Int -> Expr b
mkIntLit dflags n = Lit (mkLitInt dflags n)
mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n))
mkIntLit platform n = Lit (mkLitInt platform n)
mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n))
-- | Create a machine word literal expression of type @Word#@ from an @Integer@.
-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
mkWordLit :: DynFlags -> Integer -> Expr b
mkWordLit :: Platform -> Integer -> Expr b
-- | Create a machine word literal expression of type @Word#@ from a @Word@.
-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
mkWordLitWord :: DynFlags -> Word -> Expr b
mkWordLitWord :: Platform -> Word -> Expr b
mkWordLit dflags w = Lit (mkLitWord dflags w)
mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w))
mkWordLit platform w = Lit (mkLitWord platform w)
mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w))
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
......
......@@ -1912,11 +1912,11 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
validateCoercion :: PrimRep -> PrimRep -> LintM ()
validateCoercion rep1 rep2
= do { dflags <- getDynFlags
= do { platform <- targetPlatform <$> getDynFlags
; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
(report "between unboxed and boxed value")
; checkWarnL (TyCon.primRepSizeB dflags rep1
== TyCon.primRepSizeB dflags rep2)
; checkWarnL (TyCon.primRepSizeB platform rep1
== TyCon.primRepSizeB platform rep2)
(report "between unboxed values of different size")
; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
(TyCon.primRepIsFloat rep2)
......
......@@ -63,6 +63,7 @@ import GHC.Core
import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )
import Literal
import GHC.Driver.Types
import GHC.Platform
import TysWiredIn
import PrelNames
......@@ -81,7 +82,6 @@ import FastString
import UniqSupply
import BasicTypes
import Util
import GHC.Driver.Session
import Data.List
import Data.Char ( ord )
......@@ -250,20 +250,20 @@ castBottomExpr e res_ty
-}
-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int
mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i]
mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int
mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i]
-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int
mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i]
mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int
mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLitInt platform i]
-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
mkWordExpr :: DynFlags -> Integer -> CoreExpr
mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]
mkWordExpr :: Platform -> Integer -> CoreExpr
mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]
-- | Create a 'CoreExpr' which will evaluate to the given @Word@
mkWordExprWord :: DynFlags -> Word -> CoreExpr
mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]
mkWordExprWord :: Platform -> Word -> CoreExpr
mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w]
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
......
This diff is collapsed.
This diff is collapsed.
......@@ -13,6 +13,7 @@ module GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) where
import GhcPrelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Core.Op.Simplify.Monad
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
......@@ -3092,7 +3093,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
res_ty = contResultType cont
; (floats2, body2)
<- if exprIsDupable (seDynFlags env) join_body
<- if exprIsDupable (targetPlatform (seDynFlags env)) join_body
then return (emptyFloats env, join_body)
else do { join_bndr <- newJoinId [bndr'] res_ty
; let join_call = App (Var join_bndr) (Var bndr')
......@@ -3175,7 +3176,7 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-- NB: we don't use alt_env further; it has the substEnv for
-- the alternatives, and we don't want that
; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')
; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')
emptyJoinFloats alts'
; let all_floats = floats `addJoinFloats` join_floats
......@@ -3188,11 +3189,11 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils
, sc_cont = mkBoringStop (contResultType cont) } ) }
mkDupableAlt :: DynFlags -> OutId
mkDupableAlt :: Platform -> OutId
-> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt)
mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')
| exprIsDupable dflags rhs' -- Note [Small alternative rhs]
mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs')
| exprIsDupable platform rhs' -- Note [Small alternative rhs]
= return (jfloats, (con, bndrs', rhs'))
| otherwise
......
......@@ -2152,7 +2152,7 @@ mkCase2 dflags scrut bndr alts_ty alts
[(DEFAULT,_,_)] -> False
_ -> True
, gopt Opt_CaseFolding dflags
, Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut
, Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut
= do { bndr' <- newId (fsLit "lwild") (exprType scrut')
; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts
......
......@@ -58,7 +58,7 @@ import NameEnv
import UniqFM
import GHC.Core.Unify as Unify ( ruleMatchTyKiX )
import BasicTypes
import GHC.Driver.Session ( DynFlags )
import GHC.Driver.Session hiding (ruleCheck)
import Outputable
import FastString
import Maybes
......@@ -510,7 +510,12 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
matchRule dflags rule_env _is_active fn args _rough_args
(BuiltinRule { ru_try = match_fn })
-- Built-in rules can't be switched off, it seems
= case match_fn dflags rule_env fn args of
= let env = RuleOpts
{ roPlatform = targetPlatform dflags
, roNumConstantFolding = gopt Opt_NumConstantFolding dflags
, roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
}
in case match_fn env rule_env fn args of
Nothing -> Nothing
Just expr -> Just expr
......
......@@ -7,6 +7,7 @@ The @TyCon@ datatype
-}
{-# LANGUAGE CPP, FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Core.TyCon(
-- * Main TyCon data types
......@@ -134,6 +135,7 @@ module GHC.Core.TyCon(
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import {-# SOURCE #-} GHC.Core.TyCo.Rep
( Kind, Type, PredType, mkForAllTy, mkFunTy )
......@@ -152,7 +154,6 @@ import Var
import VarSet
import GHC.Core.Class
import BasicTypes
import GHC.Driver.Session
import ForeignCall
import Name
import NameEnv
......@@ -1474,20 +1475,20 @@ isGcPtrRep _ = False
-- A PrimRep is compatible with another iff one can be coerced to the other.
-- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.
primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool
primRepCompatible dflags rep1 rep2 =
primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool
primRepCompatible platform rep1 rep2 =
(isUnboxed rep1 == isUnboxed rep2) &&
(primRepSizeB dflags rep1 == primRepSizeB dflags rep2) &&
(primRepSizeB platform rep1 == primRepSizeB platform rep2) &&
(primRepIsFloat rep1 == primRepIsFloat rep2)
where
isUnboxed = not . isGcPtrRep
-- More general version of `primRepCompatible` for types represented by zero or
-- more than one PrimReps.
primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible dflags reps1 reps2 =
primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible platform reps1 reps2 =
length reps1 == length reps2 &&
and (zipWith (primRepCompatible dflags) reps1 reps2)
and (zipWith (primRepCompatible platform) reps1 reps2)
-- | The size of a 'PrimRep' in bytes.
--
......@@ -1496,24 +1497,25 @@ primRepsCompatible dflags reps1 reps2 =
-- take only 8 bytes, which for 64-bit arch will be equal to 1 word.
-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are
-- laid out.
primRepSizeB :: DynFlags -> PrimRep -> Int
primRepSizeB dflags IntRep = wORD_SIZE dflags
primRepSizeB dflags WordRep = wORD_SIZE dflags
primRepSizeB _ Int8Rep = 1
primRepSizeB _ Int16Rep = 2
primRepSizeB _ Int32Rep = 4
primRepSizeB _ Int64Rep = wORD64_SIZE
primRepSizeB _ Word8Rep = 1
primRepSizeB _ Word16Rep = 2
primRepSizeB _ Word32Rep = 4
primRepSizeB _ Word64Rep = wORD64_SIZE
primRepSizeB _ FloatRep = fLOAT_SIZE
primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags
primRepSizeB dflags AddrRep = wORD_SIZE dflags
primRepSizeB dflags LiftedRep = wORD_SIZE dflags
primRepSizeB dflags UnliftedRep = wORD_SIZE dflags
primRepSizeB _ VoidRep = 0
primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep
primRepSizeB :: Platform -> PrimRep -> Int
primRepSizeB platform = \case
IntRep -> platformWordSizeInBytes platform
WordRep -> platformWordSizeInBytes platform
Int8Rep -> 1
Int16Rep -> 2
Int32Rep -> 4
Int64Rep -> wORD64_SIZE
Word8Rep -> 1
Word16Rep -> 2
Word32Rep -> 4
Word64Rep -> wORD64_SIZE
FloatRep -> fLOAT_SIZE
DoubleRep -> dOUBLE_SIZE
AddrRep -> platformWordSizeInBytes platform
LiftedRep -> platformWordSizeInBytes platform
UnliftedRep -> platformWordSizeInBytes platform
VoidRep -> 0
(VecRep len rep) -> len * primElemRepSizeB rep
primElemRepSizeB :: PrimElemRep -> Int
primElemRepSizeB Int8ElemRep = 1
......
......@@ -63,6 +63,7 @@ module GHC.Core.Utils (
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import GHC.Core
import PrelNames ( makeStaticName )
......@@ -87,7 +88,6 @@ import GHC.Core.TyCon
import Unique
import Outputable
import TysPrim
import GHC.Driver.Session
import FastString
import Maybes
import ListSetOps ( minusList )
......@@ -1138,8 +1138,8 @@ Note [exprIsDupable]
and then inlining of case join points
-}
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable platform e
= isJust (go dupAppSize e)
where
go :: Int -> CoreExpr -> Maybe Int
......@@ -1149,7 +1149,7 @@ exprIsDupable dflags e
go n (Tick _ e) = go n e
go n (Cast e _) = go n e
go n (App f a) | Just n' <- go n a = go n' f
go n (Lit lit) | litIsDupable dflags lit = decrement n
go n (Lit lit) | litIsDupable platform lit = decrement n
go _ _ = Nothing
decrement :: Int -> Maybe Int
......
......@@ -296,11 +296,11 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
peep []
= []
argBits :: DynFlags -> [ArgRep] -> [Bool]
argBits _ [] = []
argBits dflags (rep : args)
| isFollowableArg rep = False : argBits dflags args