...
 
Commits (8)
  • Roland Senn's avatar
    Use export list of Main module in function TcRnDriver.hs:check_main (Fix #16453) · 703221f4
    Roland Senn authored
    - Provide the export list of the `Main` module as parameter to the
      `compiler/typecheck/TcRnDriver.hs:check_main` function.
    - Instead of `lookupOccRn_maybe` call the function `lookupInfoOccRn`.
      It returns the list `mains_all` of all the main functions in scope.
    - Select from this list `mains_all` all `main` functions that are in
      the export list of the `Main` module.
    - If this new list contains exactly one single `main` function, then
      typechecking continues.
    - Otherwise issue an appropriate error message.
    703221f4
  • Sebastian Graf's avatar
    Remove -fkill-absence and -fkill-one-shot flags · 3e27205a
    Sebastian Graf authored
    They seem to be a benchmarking vestige of the Cardinality paper and
    probably shouldn't have been merged to HEAD in the first place.
    3e27205a
  • 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
    Significant refactor of Lint · a262ea49
    Simon Peyton Jones authored
    This refactoring of Lint was triggered by #17923, which is
    fixed by this patch.
    
    The main change is this.  Instead of
       lintType :: Type -> LintM LintedKind
    we now have
       lintType :: Type -> LintM LintedType
    
    Previously, all of typeKind was effectively duplicate in lintType.
    Moreover, since we have an ambient substitution, we still had to
    apply the substition here and there, sometimes more than once. It
    was all very tricky, in the end, and made my head hurt.
    
    Now, lintType returns a fully linted type, with all substitutions
    performed on it.  This is much simpler.
    
    The same thing is needed for Coercions.  Instead of
      lintCoercion :: OutCoercion
                   -> LintM (LintedKind, LintedKind,
                             LintedType, LintedType, Role)
    we now have
      lintCoercion :: Coercion -> LintM LintedCoercion
    
    Much simpler!  The code is shorter and less bug-prone.
    
    There are a lot of knock on effects.  But life is now better.
    a262ea49
......@@ -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))
......
This diff is collapsed.
......@@ -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.
......@@ -603,7 +603,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-- TODO: Won't the following line unnecessarily trim down arity for join
-- points returning a lambda in a C(S) context?
sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
id' = set_idStrictness env id sig
id' = setIdStrictness id sig
-- See Note [NOINLINE and strictness]
......@@ -1171,8 +1171,7 @@ findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
findBndrDmd env arg_of_dfun dmd_ty id
= (dmd_ty', dmd')
where
dmd' = killUsageDemand (ae_dflags env) $
strictify $
dmd' = strictify $
trimToType starting_dmd (findTypeShape fam_envs id_ty)
(dmd_ty', starting_dmd) = peelFV dmd_ty id
......@@ -1191,10 +1190,6 @@ findBndrDmd env arg_of_dfun dmd_ty id
fam_envs = ae_fam_envs env
set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
set_idStrictness env id sig
= setIdStrictness id (killUsageSig (ae_dflags env) sig)
{- Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See section 9.2 (Finding fixpoints) of the paper.
......
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
......
......@@ -2447,7 +2447,7 @@ normally it would make no sense to have
forall r. (ty :: K r)
because the kind of the forall would escape the binding
of 'r'. But in this case it's fine because (K r) exapands
to Type, so we expliclity /permit/ the type
to Type, so we explicitly /permit/ the type
forall r. T r
To accommodate such a type, in typeKind (forall a.ty) we use
......@@ -2455,8 +2455,13 @@ occCheckExpand to expand any type synonyms in the kind of 'ty'
to eliminate 'a'. See kinding rule (FORALL) in
Note [Kinding rules for types]
And in TcValidity.checkEscapingKind, we use also use
occCheckExpand, for the same reason.
See also
* TcUnify.occCheckExpand
* GHC.Core.Utils.coreAltsType
* TcValidity.checkEscapingKind
all of which grapple with with the same problem.
See #14939.
-}
-----------------------------
......
......@@ -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
| 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
......@@ -574,10 +575,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 +653,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 +671,25 @@ cvtLitInteger dflags mk_integer _ i
f 0 = []
f x = let low = x .&. mask
high = x `shiftR` bits
in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high
in mkConApp intDataCon [Lit (mkLitInt platform low)] : f high
bits = 31
mask = 2 ^ bits - 1
cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
cvtLitNatural :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr
-- Here we convert a literal Natural to the low-level
-- representation.
-- See Note [Natural literals] in Literal
cvtLitNatural dflags _ (Just sdatacon) i
| inWordRange dflags i -- Special case for small naturals
= mkConApp sdatacon [Lit (mkLitWord dflags i)]
cvtLitNatural platform _ (Just sdatacon) i
| platformInWordRange platform i -- Special case for small naturals
= mkConApp sdatacon [Lit (mkLitWord platform i)]
cvtLitNatural dflags mk_natural _ i
cvtLitNatural platform mk_natural _ i
= mkApps (Var mk_natural) [words]
where words = mkListExpr wordTy (f i)
f 0 = []
f x = let low = x .&. mask
high = x `shiftR` bits
in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high
in mkConApp wordDataCon [Lit (mkLitWord platform low)] : f high
bits = 32
mask = 2 ^ bits - 1
......
......@@ -203,7 +203,6 @@ module GHC.Driver.Session (
wordAlignment,
tAG_MASK,
mAX_PTR_TAG,
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,
......@@ -292,13 +291,11 @@ import Control.Monad.Trans.Except
import Data.Ord
import Data.Bits
import Data.Char
import Data.Int
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word
import System.FilePath
import System.Directory
import System.Environment (lookupEnv)
......@@ -3568,8 +3565,6 @@ fFlagsDeps = [
flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified,
flagSpec "irrefutable-tuples" Opt_IrrefutableTuples,
flagSpec "keep-going" Opt_KeepGoing,
flagSpec "kill-absence" Opt_KillAbsence,
flagSpec "kill-one-shot" Opt_KillOneShot,
flagSpec "late-dmd-anal" Opt_LateDmdAnal,
flagSpec "late-specialise" Opt_LateSpecialise,
flagSpec "liberate-case" Opt_LiberateCase,
......@@ -4917,10 +4912,11 @@ compilerInfo dflags
#include "GHCConstantsHaskellWrappers.hs"
bLOCK_SIZE_W :: DynFlags -> Int
bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags
bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform
where platform = targetPlatform dflags
wordAlignment :: DynFlags -> Alignment
wordAlignment dflags = alignmentOf (wORD_SIZE dflags)
wordAlignment :: Platform -> Alignment
wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)
tAG_MASK :: DynFlags -> Int
tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
......@@ -4928,22 +4924,6 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
mAX_PTR_TAG :: DynFlags -> Int
mAX_PTR_TAG = tAG_MASK
-- Might be worth caching these in targetPlatform?
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer
tARGET_MIN_INT dflags
= case platformWordSize (targetPlatform dflags) of
PW4 -> toInteger (minBound :: Int32)
PW8 -> toInteger (minBound :: Int64)
tARGET_MAX_INT dflags
= case platformWordSize (targetPlatform dflags) of
PW4 -> toInteger (maxBound :: Int32)
PW8 -> toInteger (maxBound :: Int64)
tARGET_MAX_WORD dflags
= case platformWordSize (targetPlatform dflags) of
PW4 -> toInteger (maxBound :: Word32)
PW8 -> toInteger (maxBound :: Word64)
{- -----------------------------------------------------------------------------
Note [DynFlags consistency]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -488,6 +488,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
makeStaticId <- dsLookupGlobalId makeStaticName
dflags <- getDynFlags
let platform = targetPlatform dflags
let (line, col) = case loc of
RealSrcSpan r _ ->
( srcLocLine $ realSrcSpanStart r
......@@ -496,7 +497,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
_ -> (0, 0)
srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
[ Type intTy , Type intTy
, mkIntExprInt dflags line, mkIntExprInt dflags col
, mkIntExprInt platform line, mkIntExprInt platform col
]
putSrcSpanDs loc $ return $
......@@ -890,7 +891,8 @@ dsExplicitList elt_ty Nothing xs
dsExplicitList elt_ty (Just fln) xs
= do { list <- dsExplicitList elt_ty Nothing xs
; dflags <- getDynFlags
; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
; let platform = targetPlatform dflags
; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] }
dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq expr (From from)
......
......@@ -23,6 +23,7 @@ where
import GhcPrelude
import GHC.Platform
import GHC.Core
......@@ -152,9 +153,10 @@ unboxArg arg
| Just tc <- tyConAppTyCon_maybe arg_ty,
tc `hasKey` boolTyConKey
= do dflags <- getDynFlags
let platform = targetPlatform dflags
prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
\ body -> Case (mkIfThenElse arg (mkIntLit dflags 1) (mkIntLit dflags 0))
\ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))
prim_arg
(exprType body)
[(DEFAULT,[],body)])
......@@ -326,10 +328,11 @@ resultWrapper result_ty
| Just (tc,_) <- maybe_tc_app
, tc `hasKey` boolTyConKey
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; let marshal_bool e
= mkWildCase e intPrimTy boolTy
[ (DEFAULT ,[],Var trueDataConId )
, (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)]
[ (DEFAULT ,[],Var trueDataConId )
, (LitAlt (mkLitInt platform 0),[],Var falseDataConId)]
; return (Just intPrimTy, marshal_bool) }
-- Newtypes
......@@ -349,8 +352,9 @@ resultWrapper result_ty
, Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials
, [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
; let narrow_wrapper = maybeNarrow dflags tycon
; let narrow_wrapper = maybeNarrow platform tycon
marshal_con e = Var (dataConWrapId data_con)
`mkTyApps` tycon_arg_tys
`App` wrapper (narrow_wrapper e)
......@@ -366,15 +370,17 @@ resultWrapper result_ty
-- standard appears to say that this is the responsibility of the
-- caller, not the callee.
maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow dflags tycon
maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow platform tycon
| tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
| tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
| tycon `hasKey` int32TyConKey
&& wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
, platformWordSizeInBytes platform > 4
= \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
| tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
| tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
| tycon `hasKey` word32TyConKey
&& wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
, platformWordSizeInBytes platform > 4
= \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
| otherwise = id
......@@ -423,6 +423,7 @@ dsFExportDynamic :: Id
dsFExportDynamic id co0 cconv = do
mod <- getModule
dflags <- getDynFlags
let platform = targetPlatform dflags
let fe_nm = mkFastString $ zEncodeString
(moduleStableString mod ++ "$" ++ toCName dflags id)
-- Construct the label based on the passed id, don't use names
......@@ -444,7 +445,7 @@ dsFExportDynamic id co0 cconv = do
to be entered using an external calling convention
(stdcall, ccall).
-}
adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv)
adj_args = [ mkIntLitInt platform (ccallConvToInt cconv)
, Var stbl_value
, Lit (LitLabel fe_nm mb_sz_args IsFunction)
, Lit (mkLitString typestring)
......@@ -549,10 +550,10 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
type_string
-- libffi needs to know the result type too:
| libffi = primTyDescChar dflags res_hty : arg_type_string
| libffi = primTyDescChar platform res_hty : arg_type_string
| otherwise = arg_type_string
arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
-- just the real args
-- add some auxiliary args; the stable ptr in the wrapper case, and
......@@ -802,8 +803,8 @@ getPrimTyOf ty
-- represent a primitive type as a Char, for building a string that
-- described the foreign function type. The types are size-dependent,
-- e.g. 'W' is a signed 32-bit integer.
primTyDescChar :: DynFlags -> Type -> Char
primTyDescChar dflags ty
primTyDescChar :: Platform -> Type -> Char
primTyDescChar platform ty
| ty `eqType` unitTy = 'v'
| otherwise
= case typePrimRep1 (getPrimTyOf ty) of
......@@ -816,7 +817,6 @@ primTyDescChar dflags ty
DoubleRep -> 'd'
_ -> pprPanic "primTyDescChar" (ppr ty)
where
(signed_word, unsigned_word)
| wORD_SIZE dflags == 4 = ('W','w')
| wORD_SIZE dflags == 8 = ('L','l')
| otherwise = panic "primTyDescChar"
(signed_word, unsigned_word) = case platformWordSize platform of
PW4 -> ('W','w')
PW8 -> ('L','l')
......@@ -24,6 +24,7 @@ where
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
......@@ -186,11 +187,12 @@ match [] ty eqns
match (v:vs) ty eqns -- Eqns *can* be empty
= ASSERT2( all (isInternalName . idName) vars, ppr vars )
do { dflags <- getDynFlags
; let platform = targetPlatform dflags
-- Tidy the first pattern, generating
-- auxiliary bindings if necessary
; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
; let grouped = groupEquations dflags tidy_eqns
; let grouped = groupEquations platform tidy_eqns
-- print the view patterns that are commoned up to help debug
; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
......@@ -910,13 +912,13 @@ the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
for overloaded strings.
-}
groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
-- The ordering of equations is unchanged
groupEquations dflags eqns
= NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
groupEquations platform eqns
= NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
-- comprehension on NonEmpty
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
......@@ -1117,7 +1119,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_list _ (_:_) [] = False
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
patGroup :: DynFlags -> Pat GhcTc -> PatGroup
patGroup :: Platform -> Pat GhcTc -> PatGroup
patGroup _ (ConPatOut { pat_con = L _ con
, pat_arg_tys = tys })
| RealDataCon dcon <- con = PgCon dcon
......@@ -1140,7 +1142,7 @@ patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p)
-- Type of innelexp pattern
patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit)
patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit)
patGroup _ pat = pprPanic "patGroup" (ppr pat)
{-
......
......@@ -24,6 +24,7 @@ where
#include "HsVersions.h"
import GhcPrelude
import GHC.Platform
import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr )
......@@ -88,19 +89,20 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
dsLit :: HsLit GhcRn -> DsM CoreExpr
dsLit l = do
dflags <- getDynFlags
let platform = targetPlatform dflags
case l of
HsStringPrim _ s -> return (Lit (LitString s))
HsCharPrim _ c -> return (Lit (LitChar c))
HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i))
HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w))
HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i))
HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))
HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i))
HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w))
HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap platform i))
HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w))
HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f)))
HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
HsChar _ c -> return (mkCharExpr c)
HsString _ str -> mkStringExprFS str
HsInteger _ i _ -> mkIntegerExpr i
HsInt _ i -> return (mkIntExpr dflags (il_value i))
HsInt _ i -> return (mkIntExpr platform (il_value i))
XLit nec -> noExtCon nec
HsRat _ (FL _ _ val) ty -> do
num <- mkIntegerExpr (numerator val)
......@@ -119,7 +121,8 @@ dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
, ol_witness = witness }) = do
dflags <- getDynFlags
case shortCutLit dflags val ty of
let platform = targetPlatform dflags
case shortCutLit platform val ty of
Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut]
_ -> dsExpr witness
dsOverLit (XOverLit nec) = noExtCon nec
......@@ -426,9 +429,10 @@ matchLiterals (var :| vars) ty sub_groups
match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)
match_group eqns@(firstEqn :| _)
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; let LitPat _ hs_lit = firstPat firstEqn
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey dflags hs_lit, match_result) }
; return (hsLitKey platform hs_lit, match_result) }
wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
-- Equality check for string literals
......@@ -443,7 +447,7 @@ matchLiterals (var :| vars) ty sub_groups
---------------------------
hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
hsLitKey :: Platform -> HsLit GhcTc -> Literal
-- Get the