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

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.
......@@ -21,6 +21,7 @@ module GHC.Core.Op.FloatIn ( floatInwards ) where
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import GHC.Core
import GHC.Core.Make hiding ( wrapFloats )
......@@ -46,12 +47,13 @@ actually float any bindings downwards from the top-level.
floatInwards :: ModGuts -> CoreM ModGuts
floatInwards pgm@(ModGuts { mg_binds = binds })
= do { dflags <- getDynFlags
; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }
; let platform = targetPlatform dflags
; return (pgm { mg_binds = map (fi_top_bind platform) binds }) }
where
fi_top_bind dflags (NonRec binder rhs)
= NonRec binder (fiExpr dflags [] (freeVars rhs))
fi_top_bind dflags (Rec pairs)
= Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]
fi_top_bind platform (NonRec binder rhs)
= NonRec binder (fiExpr platform [] (freeVars rhs))
fi_top_bind platform (Rec pairs)
= Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ]
{-
......@@ -137,7 +139,7 @@ data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
type FloatInBinds = [FloatInBind]
-- In reverse dependency order (innermost binder first)
fiExpr :: DynFlags
fiExpr :: Platform
-> FloatInBinds -- Binds we're trying to drop
-- as far "inwards" as possible
-> CoreExprWithFVs -- Input expr
......@@ -148,12 +150,12 @@ fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit)
fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v)
fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))
fiExpr platform to_drop (_, AnnCast expr (co_ann, co))
= wrapFloats (drop_here ++ co_drop) $
Cast (fiExpr dflags e_drop expr) co
Cast (fiExpr platform e_drop expr) co
where
[drop_here, e_drop, co_drop]
= sepBindsByDropPoint dflags False
= sepBindsByDropPoint platform False
[freeVarsOf expr, freeVarsOfAnn co_ann]
to_drop
......@@ -163,11 +165,11 @@ need to get at all the arguments. The next simplifier run will
pull out any silly ones.
-}
fiExpr dflags to_drop ann_expr@(_,AnnApp {})
fiExpr platform to_drop ann_expr@(_,AnnApp {})
= wrapFloats drop_here $ wrapFloats extra_drop $
mkTicks ticks $
mkApps (fiExpr dflags fun_drop ann_fun)
(zipWith (fiExpr dflags) arg_drops ann_args)
mkApps (fiExpr platform fun_drop ann_fun)
(zipWith (fiExpr platform) arg_drops ann_args)
where
(ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
fun_ty = exprType (deAnnotate ann_fun)
......@@ -175,7 +177,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
arg_fvs = map freeVarsOf ann_args
(drop_here : extra_drop : fun_drop : arg_drops)
= sepBindsByDropPoint dflags False
= sepBindsByDropPoint platform False
(extra_fvs : fun_fvs : arg_fvs)
to_drop
-- Shortcut behaviour: if to_drop is empty,
......@@ -306,13 +308,13 @@ be dropped right away.
-}
fiExpr dflags to_drop lam@(_, AnnLam _ _)
fiExpr platform to_drop lam@(_, AnnLam _ _)
| noFloatIntoLam bndrs -- Dump it all here
-- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088
= wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))
= wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))
| otherwise -- Float inside
= mkLams bndrs (fiExpr dflags to_drop body)
= mkLams bndrs (fiExpr platform to_drop body)
where
(bndrs, body) = collectAnnBndrs lam
......@@ -324,12 +326,12 @@ We don't float lets inwards past an SCC.
cc, change current cc to the new one and float binds into expr.
-}
fiExpr dflags to_drop (_, AnnTick tickish expr)
fiExpr platform to_drop (_, AnnTick tickish expr)
| tickish `tickishScopesLike` SoftScope
= Tick tickish (fiExpr dflags to_drop expr)
= Tick tickish (fiExpr platform to_drop expr)
| otherwise -- Wimp out for now - we could push values in
= wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))
= wrapFloats to_drop (Tick tickish (fiExpr platform [] expr))
{-
For @Lets@, the possible ``drop points'' for the \tr{to_drop}
......@@ -382,11 +384,11 @@ idRuleAndUnfoldingVars of x. No need for type variables, hence not using
idFreeVars.
-}
fiExpr dflags to_drop (_,AnnLet bind body)
= fiExpr dflags (after ++ new_float : before) body
fiExpr platform to_drop (_,AnnLet bind body)
= fiExpr platform (after ++ new_float : before) body
-- to_drop is in reverse dependency order