...
 
Commits (6)
  • Peter Trommler's avatar
    Do not panic on linker errors · 262e42aa
    Peter Trommler authored
    262e42aa
  • Sylvain Henry's avatar
    DynFlags refactoring III · 0de03cd7
    Sylvain Henry authored
    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
    0de03cd7
  • Tristan Cacqueray's avatar
    Base: fix a typo in liftA doc · 7a04920b
    Tristan Cacqueray authored
    This change removes an extra '|' that should not be rendered in
    the liftA documentation.
    
    Tracking: #17929
    7a04920b
  • Tristan Cacqueray's avatar
    Base: add Control.Applicative optional example · 1c5a15f7
    Tristan Cacqueray authored
    This change adds an optional example.
    
    Tracking: #17929
    1c5a15f7
  • Tristan Cacqueray's avatar
    Base: add markup around Except · 6d172e63
    Tristan Cacqueray authored
    6d172e63
  • Simon Peyton Jones's avatar
    Re-engineer the binder-swap transformation · f299ed57
    Simon Peyton Jones authored
    The binder-swap transformation is implemented by the occurrence
    analyser -- see Note [Binder swap] in OccurAnal. However it had
    a very nasty corner in it, for the case where the case scrutinee
    was a GlobalId.  This led to trouble and hacks, and ultimately
    to #16296.
    
    This patch re-engineers how the occurrence analyser implements
    the binder-swap, by actually carrying out a substitution rather
    than by adding a let-binding.  It's all described in
    Note [The binder-swap substitution].
    
    I did a few other things along the way
    
    * Fix a bug in StgCse, which could allow a loop breaker to be CSE'd
      away.  See Note [Care with loop breakers] in StgCse.  I think it can
      only show up if occurrence analyser sets up bad loop breakers, but
      still.
    
    * Better commenting in SimplUtils.prepareAlts
    
    * A little refactoring in CoreUnfold; nothing significant
      e.g. rename CoreUnfold.mkTopUnfolding to mkFinalUnfolding
    
    * Renamed CoreSyn.isFragileUnfolding to hasCoreUnfolding
    
    * Move mkRuleInfo to CoreFVs
    
    There's a 4.6% metric decrease here:
    
    Metric Decrease:
        T9961
    f299ed57
......@@ -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
......
......@@ -69,7 +69,7 @@ module GHC.Core (
maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, isFragileUnfolding, hasSomeUnfolding,
isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding,
isBootUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
......@@ -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
......@@ -1732,14 +1739,13 @@ neverUnfoldGuidance :: UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfNever = True
neverUnfoldGuidance _ = False
isFragileUnfolding :: Unfolding -> Bool
-- An unfolding is fragile if it mentions free variables or
-- is otherwise subject to change. A robust one can be kept.
-- See Note [Fragile unfoldings]
isFragileUnfolding (CoreUnfolding {}) = True
isFragileUnfolding (DFunUnfolding {}) = True
isFragileUnfolding _ = False
-- NoUnfolding, BootUnfolding, OtherCon are all non-fragile
hasCoreUnfolding :: Unfolding -> Bool
-- An unfolding "has Core" if it contains a Core expression, which
-- may mention free variables. See Note [Fragile unfoldings]
hasCoreUnfolding (CoreUnfolding {}) = True
hasCoreUnfolding (DFunUnfolding {}) = True
hasCoreUnfolding _ = False
-- NoUnfolding, BootUnfolding, OtherCon have no Core
canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
......@@ -1963,23 +1969,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))
......
......@@ -35,7 +35,7 @@ module GHC.Core.FVs (
idFVs,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet,
rulesFreeVarsDSet, mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
expr_fvs,
......@@ -469,6 +469,11 @@ rulesFVs = mapUnionFV ruleFVs
rulesFreeVarsDSet :: [CoreRule] -> DVarSet
rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
-- for putting into an 'IdInfo'
mkRuleInfo :: [CoreRule] -> RuleInfo
mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
-- Just the variables free on the *rhs* of a rule
idRuleRhsVars is_active id
......
......@@ -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.
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 )
......@@ -44,7 +45,8 @@ import GHC.Core.Unfold
import GHC.Core.Utils
import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.Rules ( mkRuleInfo, lookupRule, getRules )
import GHC.Core.Rules ( lookupRule, getRules )
import GHC.Core.FVs ( mkRuleInfo )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
RecFlag(..), Arity )
import MonadUtils ( mapAccumLM, liftIO )
......@@ -1421,7 +1423,7 @@ simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- fw a b x{=(a,b)} = ...
-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
simplLamBndr env bndr
| isId bndr && isFragileUnfolding old_unf -- Special case
| isId bndr && hasCoreUnfolding old_unf -- Special case
= do { (env1, bndr1) <- simplBinder env bndr
; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr
old_unf (idType bndr1)
......@@ -2882,7 +2884,7 @@ the unfolding (a,b), and *that* mentions b. If f has a RULE
RULE f (p, I# q) = ...
we want that rule to match, so we must extend the in-scope env with a
suitable unfolding for 'y'. It's *essential* for rule matching; but
it's also good for case-elimintation -- suppose that 'f' was inlined
it's also good for case-elimination -- suppose that 'f' was inlined
and did multi-level case analysis, then we'd solve it in one
simplifier sweep instead of two.
......@@ -3092,7 +3094,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 +3177,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 +3190,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
......
......@@ -1872,22 +1872,26 @@ Historical note: if you use let-bindings instead of a substitution, beware of th
prepareAlts tries these things:
1. Eliminate alternatives that cannot match, including the
DEFAULT alternative.
1. filterAlts: eliminate alternatives that cannot match, including
the DEFAULT alternative. Here "cannot match" includes knowledge
from GADTs
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
2. refineDefaultAlt: if the DEFAULT alternative can match only one
possible constructor, then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
See CoreUtils Note [Refine DEFAULT case alternatives]
3. Returns a list of the constructors that cannot holds in the
DEFAULT alternative (if there is one)
3. combineIdenticalAlts: combine identical alternatives into a DEFAULT.
See CoreUtils Note [Combine identical alternatives], which also
says why we do this on InAlts not on OutAlts
Here "cannot match" includes knowledge from GADTs
4. Returns a list of the constructors that cannot holds in the
DEFAULT alternative (if there is one)
It's a good idea to do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
......@@ -2152,7 +2156,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
......
......@@ -17,7 +17,7 @@ module GHC.Core.Rules (
ruleCheckProgram,
-- ** Manipulating 'RuleInfo' rules
mkRuleInfo, extendRuleInfo, addRuleInfo,
extendRuleInfo, addRuleInfo,
addIdSpecialisations,
-- * Misc. CoreRule helpers
......@@ -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
......@@ -278,11 +278,6 @@ pprRulesForUser dflags rules
************************************************************************
-}
-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
-- for putting into an 'IdInfo'
mkRuleInfo :: [CoreRule] -> RuleInfo
mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo (RuleInfo rs1 fvs1) rs2
= RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)
......@@ -510,7 +505,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
......
......@@ -618,7 +618,7 @@ substIdInfo subst new_id info
where
old_rules = ruleInfo info
old_unf = unfoldingInfo info
nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf)
nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf)
------------------
-- | Substitutes for the 'Id's within an unfolding
......
......@@ -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
......
......@@ -22,9 +22,9 @@ find, unsurprisingly, a Core expression.
module GHC.Core.Unfold (
Unfolding, UnfoldingGuidance, -- Abstract types
noUnfolding, mkImplicitUnfolding,
noUnfolding,
mkUnfolding, mkCoreUnfolding,
mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
mkFinalUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
mkInlineUnfolding, mkInlineUnfoldingWithArity,
mkInlinableUnfolding, mkWwInlineRule,
mkCompulsoryUnfolding, mkDFunUnfolding,
......@@ -48,12 +48,12 @@ import GhcPrelude
import GHC.Driver.Session
import GHC.Core
import GHC.Core.Op.OccurAnal ( occurAnalyseExpr_NoBinderSwap )
import GHC.Core.Op.OccurAnal ( occurAnalyseExpr )
import GHC.Core.SimpleOpt
import GHC.Core.Arity ( manifestArity )
import GHC.Core.Utils
import Id
import Demand ( isBottomingSig )
import Demand ( StrictSig, isBottomingSig )
import GHC.Core.DataCon
import Literal
import PrimOp
......@@ -80,14 +80,22 @@ import Data.List
************************************************************************
-}
mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding
mkTopUnfolding dflags is_bottoming rhs
= mkUnfolding dflags InlineRhs True is_bottoming rhs
mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
-- "Final" in the sense that this is a GlobalId that will not be further
-- simplified; so the unfolding should be occurrence-analysed
mkFinalUnfolding dflags src strict_sig expr
= mkUnfolding dflags src
True {- Top level -}
(isBottomingSig strict_sig)
expr
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= mkCoreUnfolding InlineCompulsory True
(simpleOptExpr unsafeGlobalDynFlags expr)
(UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
, ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding
-- For implicit Ids, do a tiny bit of optimising first
mkImplicitUnfolding dflags expr
= mkTopUnfolding dflags False (simpleOptExpr dflags expr)
-- Note [Top-level flag on inline rules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -103,7 +111,7 @@ mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
= DFunUnfolding { df_bndrs = bndrs
, df_con = con
, df_args = map occurAnalyseExpr_NoBinderSwap ops }
, df_args = map occurAnalyseExpr ops }
-- See Note [Occurrence analysis of unfoldings]
mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding
......@@ -113,13 +121,6 @@ mkWwInlineRule dflags expr arity
(UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtNotOk })
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= mkCoreUnfolding InlineCompulsory True
(simpleOptExpr unsafeGlobalDynFlags expr)
(UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
, ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Op.WorkWrap
mkWorkerUnfolding dflags work_fn
......@@ -309,20 +310,6 @@ I'm a bit worried that it's possible for the same kind of problem
to arise for non-0-ary functions too, but let's wait and see.
-}
mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
-> UnfoldingGuidance -> Unfolding
-- Occurrence-analyses the expression before capturing it
mkCoreUnfolding src top_lvl expr guidance
= CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr,
-- See Note [Occurrence analysis of unfoldings]
uf_src = src,
uf_is_top = top_lvl,
uf_is_value = exprIsHNF expr,
uf_is_conlike = exprIsConLike expr,
uf_is_work_free = exprIsWorkFree expr,
uf_expandable = exprIsExpandable expr,
uf_guidance = guidance }
mkUnfolding :: DynFlags -> UnfoldingSource
-> Bool -- Is top-level
-> Bool -- Definitely a bottoming binding
......@@ -331,21 +318,28 @@ mkUnfolding :: DynFlags -> UnfoldingSource
-> Unfolding
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
mkUnfolding dflags src is_top_lvl is_bottoming expr
= CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr,
mkUnfolding dflags src top_lvl is_bottoming expr
= mkCoreUnfolding src top_lvl expr guidance
where
is_top_bottoming = top_lvl && is_bottoming
guidance = calcUnfoldingGuidance dflags is_top_bottoming expr
-- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
-> UnfoldingGuidance -> Unfolding
-- Occurrence-analyses the expression before capturing it
mkCoreUnfolding src top_lvl expr guidance
= CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
-- See Note [Occurrence analysis of unfoldings]
uf_src = src,
uf_is_top = is_top_lvl,
uf_is_top = top_lvl,
uf_is_value = exprIsHNF expr,
uf_is_conlike = exprIsConLike expr,
uf_expandable = exprIsExpandable expr,
uf_is_work_free = exprIsWorkFree expr,
uf_expandable = exprIsExpandable expr,
uf_guidance = guidance }
where
is_top_bottoming = is_top_lvl && is_bottoming
guidance = calcUnfoldingGuidance dflags is_top_bottoming expr
-- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))!
-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
{-
Note [Occurrence analysis of unfoldings]
......@@ -366,39 +360,6 @@ But more generally, the simplifier is designed on the
basis that it is looking at occurrence-analysed expressions, so better
ensure that they actually are.
We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr;
see Note [No binder swap in unfoldings].
Note [No binder swap in unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The binder swap can temporarily violate Core Lint, by assigning
a LocalId binding to a GlobalId. For example, if A.foo{r872}
is a GlobalId with unique r872, then
case A.foo{r872} of bar {
K x -> ...(A.foo{r872})...
}
gets transformed to
case A.foo{r872} of bar {
K x -> let foo{r872} = bar
in ...(A.foo{r872})...
This is usually not a problem, because the simplifier will transform
this to:
case A.foo{r872} of bar {
K x -> ...(bar)...
However, after occurrence analysis but before simplification, this extra 'let'
violates the Core Lint invariant that we do not have local 'let' bindings for
GlobalIds. That seems (just) tolerable for the occurrence analysis that happens
just before the Simplifier, but not for unfoldings, which are Linted
independently.
As a quick workaround, we disable binder swap in this module.
See #16288 and #16296 for further plans.
Note [Calculate unfolding guidance on the non-occ-anal'd expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we give the non-occur-analysed expression to
......
......@@ -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 )
......@@ -696,7 +696,7 @@ filterAlts _tycon inst_tys imposs_cons alts
impossible_alt _ _ = False
-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.
-- See Note [Refine Default Alts]
-- See Note [Refine DEFAULT case alternatives]
refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders
-> TyCon -- ^ Type constructor of scrutinee's type
-> [Type] -- ^ Type arguments of scrutinee's type
......@@ -739,95 +739,62 @@ refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
| otherwise -- The common case
= (False, all_alts)
{- Note [Refine Default Alts]
refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one
possible value it could be.
{- Note [Refine DEFAULT case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
refineDefaultAlt replaces the DEFAULT alt with a constructor if there
is one possible value it could be.
The simplest example being
foo :: () -> ()
foo x = case x of !_ -> ()
which rewrites to
foo :: () -> ()
foo x = case x of () -> ()
There are two reasons in general why replacing a DEFAULT alternative
with a specific constructor is desirable.
1. We can simplify inner expressions. For example
data Foo = Foo1 ()
test :: Foo -> ()
test x = case x of
DEFAULT -> mid (case x of
Foo1 x1 -> x1)
refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then
x becomes bound to `Foo ip1` so is inlined into the other case
which causes the KnownBranch optimisation to kick in. If we don't
refine DEFAULT to `Foo ip1`, we are left with both case expressions.
2. combineIdenticalAlts does a better job. For exapple (Simon Jacobi)
data D = C0 | C1 | C2
case e of
DEFAULT -> e0
C0 -> e1
C1 -> e1
When we apply combineIdenticalAlts to this expression, it can't
combine the alts for C0 and C1, as we already have a default case.
But if we apply refineDefaultAlt first, we get
case e of
C0 -> e1
C1 -> e1
C2 -> e0
and combineIdenticalAlts can turn that into
case e of
DEFAULT -> e1
C2 -> e0
foo :: () -> ()
foo x = case x of !_ -> ()
rewrites to
foo :: () -> ()
foo x = case x of () -> ()
There are two reasons in general why this is desirable.
1. We can simplify inner expressions
In this example we can eliminate the inner case by refining the outer case.
If we don't refine it, we are left with both case expressions.
```
{-# LANGUAGE BangPatterns #-}
module Test where
mid x = x
{-# NOINLINE mid #-}
data Foo = Foo1 ()
test :: Foo -> ()
test x =
case x of
!_ -> mid (case x of
Foo1 x1 -> x1)
```
refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x
becomes bound to `Foo ip1` so is inlined into the other case which
causes the KnownBranch optimisation to kick in.
2. combineIdenticalAlts does a better job
Simon Jakobi also points out that that combineIdenticalAlts will do a better job
if we refine the DEFAULT first.
```
data D = C0 | C1 | C2
case e of
DEFAULT -> e0
C0 -> e1
C1 -> e1
```
When we apply combineIdenticalAlts to this expression, it can't
combine the alts for C0 and C1, as we already have a default case.
If we apply refineDefaultAlt first, we get
```
case e of
C0 -> e1
C1 -> e1
C2 -> e0
```
and combineIdenticalAlts can turn that into
```
case e of
DEFAULT -> e1
C2 -> e0
```
It isn't obvious that refineDefaultAlt does this but if you look at its one call
site in GHC.Core.Op.Simplify.Utils then the `imposs_deflt_cons` argument is
populated with constructors which are matched elsewhere.
-}
It isn't obvious that refineDefaultAlt does this but if you look
at its one call site in GHC.Core.Op.Simplify.Utils then the
`imposs_deflt_cons` argument is populated with constructors which
are matched elsewhere.
{- Note [Combine identical alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Combine identical alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If several alternatives are identical, merge them into a single
DEFAULT alternative. I've occasionally seen this making a big
difference:
......@@ -1138,8 +1105,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 +1116,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
| otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
argBits :: Platform -> [ArgRep] -> [Bool]
argBits _ [] = []
argBits platform (rep : args)
| isFollowableArg rep = False : argBits platform args
| otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args
-- -----------------------------------------------------------------------------
-- schemeTopBind
......@@ -390,12 +390,12 @@ schemeR_wrk fvs nm original_body (args, body)
-- Stack arguments always take a whole number of words, we never pack
-- them unlike constructor fields.
szsb_args = map (wordsToBytes platform . idSizeW dflags) all_args
szsb_args = map (wordsToBytes platform . idSizeW platform) all_args
sum_szsb_args = sum szsb_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
-- make the arg bitmap
bits = argBits dflags (reverse (map bcIdArgRep all_args))
bits = argBits platform (reverse (map bcIdArgRep all_args))
bitmap_size = genericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
......@@ -518,8 +518,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- saturated constructor application.
-- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
dflags <- getDynFlags
let platform = targetPlatform dflags
platform <- targetPlatform <$> getDynFlags
let !d2 = d + wordSize platform
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
......@@ -527,10 +526,9 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
schemeE d s p (AnnLet binds (_,body)) = do
dflags <- getDynFlags
platform <- targetPlatform <$> getDynFlags
let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
platform = targetPlatform dflags
n_binds = genericLength xs
fvss = map (fvsToEnv p' . fst) rhss
......@@ -539,7 +537,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
(xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss
-- Sizes of free vars
size_w = trunc16W . idSizeW dflags
size_w = trunc16W . idSizeW platform
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
......@@ -1029,7 +1027,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- depth of stack after the return value has been pushed
d_bndr =
d + ret_frame_size_b + wordsToBytes platform (idSizeW dflags bndr)
d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr)
-- depth of stack after the extra info table for an unboxed return
-- has been pushed, if any. This is the stack depth at the
......@@ -1236,7 +1234,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
code_n_reps <- pargs d0 args_r_to_l
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)
push_args = concatOL pushs_arg
!d_after_args = d0 + wordsToBytes platform a_reps_sizeW
......@@ -1326,12 +1324,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Push the return placeholder. For a call returning nothing,
-- this is a V (tag).
r_sizeW = repSizeWords dflags r_rep
r_sizeW = repSizeWords platform r_rep
d_after_r = d_after_Addr + wordsToBytes platform r_sizeW
push_r =
if returns_void
then nilOL
else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))
-- generate the marshalling code we're going to call
......@@ -1394,11 +1392,11 @@ primRepToFFIType platform r
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
mkDummyLiteral :: DynFlags -> PrimRep -> Literal
mkDummyLiteral dflags pr
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral platform pr
= case pr of
IntRep -> mkLitInt dflags 0
WordRep -> mkLitWord dflags 0
IntRep -> mkLitInt platform 0
WordRep -> mkLitWord platform 0
Int64Rep -> mkLitInt64 0
Word64Rep -> mkLitWord64 0
AddrRep -> LitNullAddr
......@@ -1575,15 +1573,13 @@ pushAtom d p (AnnVar var)
| Just primop <- isPrimOpId_maybe var
= do
dflags <- getDynFlags
let platform = targetPlatform dflags
platform <- targetPlatform <$> getDynFlags
return (unitOL (PUSH_PRIMOP primop), wordSize platform)
| Just d_v <- lookupBCEnv_maybe var p -- var is a local variable
= do dflags <- getDynFlags
let platform = targetPlatform dflags
= do platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon dflags var
let !szb = idSizeCon platform var
with_instr instr = do
let !off_b = trunc16B $ d - d_v
return (unitOL (instr off_b), wordSize platform)
......@@ -1605,22 +1601,20 @@ pushAtom d p (AnnVar var)
| otherwise -- var must be a global variable
= do topStrings <- getTopStrings
dflags <- getDynFlags
platform <- targetPlatform <$> getDynFlags
case lookupVarEnv topStrings var of
Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $
Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
let sz = idSizeCon dflags var
let platform = targetPlatform dflags
let sz = idSizeCon platform var
MASSERT( sz == wordSize platform )
return (unitOL (PUSH_G (getName var)), sz)
pushAtom _ _ (AnnLit lit) = do
dflags <- getDynFlags
let platform = targetPlatform dflags
platform <- targetPlatform <$> getDynFlags
let code rep
= let size_words = WordOff (argRepSizeW dflags rep)
= let size_words = WordOff (argRepSizeW platform rep)
in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
wordsToBytes platform size_words)
......@@ -1659,8 +1653,8 @@ pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =
pushConstrAtom d p (AnnVar v)
| Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
dflags <- getDynFlags
let !szb = idSizeCon dflags v
platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon platform v
done instr = do
let !off = trunc16B $ d - d_v
return (unitOL (instr off), szb)
......@@ -1824,11 +1818,11 @@ instance Outputable Discr where
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe = Map.lookup
idSizeW :: DynFlags -> Id -> WordOff
idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
idSizeW :: Platform -> Id -> WordOff
idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep
idSizeCon :: DynFlags -> Id -> ByteOff
idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep
bcIdArgRep :: Id -> ArgRep
bcIdArgRep = toArgRep . bcIdPrimRep
......@@ -1840,8 +1834,8 @@ bcIdPrimRep id
| otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
repSizeWords :: DynFlags -> PrimRep -> WordOff
repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)
isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True
......
......@@ -608,11 +608,11 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- or foreign call.
-- Wanted: a better solution than this hacky warning
dflags <- getDynFlags
platform <- targetPlatform <$> getDynFlags
let
arg_rep = typePrimRep (exprType arg)
stg_arg_rep = typePrimRep (stgArgType stg_arg)
bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)
bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
return (stg_arg : stg_args, ticks ++ aticks)
......
......@@ -18,6 +18,7 @@ module GHC.CoreToStg.Prep (
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import GHC.Core.Op.OccurAnal
......@@ -346,10 +347,7 @@ The way we fix this is to:
* In cloneBndr, drop all unfoldings/rules
* In deFloatTop, run a simple dead code analyser on each top-level
RHS to drop the dead local bindings. For that call to OccAnal, we
disable the binder swap, else the occurrence analyser sometimes
introduces new let bindings for cased binders, which lead to the bug
in #5433.
RHS to drop the dead local bindings.
The reason we don't just OccAnal the whole output of CorePrep is that
the tidier ensures that all top-level binders are GlobalIds, so they
......@@ -574,10 +572,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
cpeRhsE env (Lit (LitNumber LitNumInteger i _))
= cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
= cpeRhsE env (cvtLitInteger (targetPlatform (cpe_dynFlags env)) (getMkIntegerId env)
(cpe_integerSDataCon env) i)
cpeRhsE env (Lit (LitNumber LitNumNatural i _))
= cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
= cpeRhsE env (cvtLitNatural (targetPlatform (cpe_dynFlags env)) (getMkNaturalId env)
(cpe_naturalSDataCon env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
......@@ -652,17 +650,17 @@ cpeRhsE env (Case scrut bndr ty alts)
; rhs' <- cpeBodyNF env2 rhs
; return (con, bs', rhs') }
cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
cvtLitInteger :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr
-- Here we convert a literal Integer to the low-level
-- representation. Exactly how we do this depends on the
-- library that implements Integer. If it's GMP we
-- use the S# data constructor for small literals.
-- See Note [Integer literals] in Literal
cvtLitInteger dflags _ (Just sdatacon) i
| inIntRange dflags i -- Special case for small integers
= mkConApp sdatacon [Lit (mkLitInt dflags i)]
cvtLitInteger platform _ (Just sdatacon) i
| platformInIntRange platform i -- Special case for small integers
= mkConApp sdatacon [Lit (mkLitInt platform i)]
cvtLitInteger dflags mk_integer _ i
cvtLitInteger platform mk_integer _ i
= mkApps (Var mk_integer) [isNonNegative, ints]
where isNonNegative = if i < 0 then mkConApp falseDataCon []
else mkConApp trueDataCon []
......@@ -670,25 +668,25 @@ cvtLitInteger dflags mk_integer _ i
f 0 = []
f x = let low = x .&. mask
high = x `shiftR` bits