...
 
Commits (104)
......@@ -107,6 +107,7 @@ _darcs/
/distrib/ghc.iss
/docs/man
/docs/index.html
/docs/users_guide/.log
/docs/users_guide/users_guide
/docs/users_guide/ghc.1
/docs/users_guide/flags.pyc
......@@ -227,7 +228,7 @@ ghc.nix/
.gdbinit
# Tooling - direnv
.envrc
.envrc
# Tooling - vscode
.vscode
......@@ -18,13 +18,14 @@ before_script:
- "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
stages:
- lint # Source linting
- build # A quick smoke-test to weed out broken commits
- full-build # Build all the things
- cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
- lint # Source linting
- quick-build # A very quick smoke-test to weed out broken commits
- build # A quick smoke-test to weed out broken commits
- full-build # Build all the things
- cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
# N.B.Don't run on wip/ branches, instead on run on merge requests.
.only-default: &only-default
......@@ -229,7 +230,7 @@ validate-x86_64-linux-deb9-hadrian:
hadrian-ghc-in-ghci:
<<: *only-default
stage: build
stage: quick-build
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
before_script:
# workaround for docker permissions
......@@ -237,6 +238,8 @@ hadrian-ghc-in-ghci:
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
variables:
GHC_FLAGS: -Werror
tags:
- x86_64-linux
script:
......
......@@ -842,6 +842,48 @@ AC_DEFUN([FP_CHECK_SIZEOF_AND_ALIGNMENT],
FP_CHECK_ALIGNMENT([$1])
])# FP_CHECK_SIZEOF_AND_ALIGNMENT
# FP_DEFAULT_CHOICE_OVERRIDE_CHECK(
# flag, name, anti name, var name, help string,
# [var true val], [var false val], [flag true val])
# ---------------------------------------------------
# Helper for when there is a automatic detection and an explicit flag for the
# user to override disable a feature, but not override enable a feature.
#
# $1 = flag of feature
# $2 = name of feature
# $3 = name of anti feature
# $4 = name of variable
# $5 = help string
# $6 = when true
# $7 = when false
# $8 = default explicit case (yes/no). Used for handle "backwards" legacy
# options where enabling makes fewer assumptions than disabling.
AC_DEFUN(
[FP_DEFAULT_CHOICE_OVERRIDE_CHECK],
[AC_ARG_ENABLE(
[$1],
[AC_HELP_STRING(
[--enable-$1],
[$5])],
[AS_IF(
[test x"$enableval" = x"m4_default([$8],yes)"],
[AS_CASE(
[x"$$4Default"],
[x"m4_default([$6],YES)"],
[AC_MSG_NOTICE([user chose $2 matching default for platform])],
[x"m4_default([$7],NO)"],
[AC_MSG_ERROR([user chose $2 overriding only supported option for platform])],
[AC_MSG_ERROR([invalid default])])
$4=m4_default([$6],YES)],
[AS_CASE(
[x"$$4Default"],
[x"m4_default([$6],YES)"],
[AC_MSG_NOTICE([user chose $3 overriding for platform])],
[x"m4_default([$7],NO)"],
[AC_MSG_NOTICE([user chose $3 matching default for platform])],
[AC_MSG_ERROR([invalid default])])
$4=m4_default([$7],NO)])],
[$4="$$4Default"])])
# FP_LEADING_UNDERSCORE
# ---------------------
......@@ -1293,30 +1335,19 @@ AC_SUBST(GccLT46)
dnl Check to see if the C compiler is clang or llvm-gcc
dnl
GccIsClang=NO
AC_DEFUN([FP_CC_LLVM_BACKEND],
[AC_REQUIRE([AC_PROG_CC])
AC_MSG_CHECKING([whether C compiler is clang])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
$CC -x c /dev/null -dM -E > conftest.txt 2>&1
if grep "__clang__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [1])
AC_SUBST([CC_LLVM_BACKEND], [1])
GccIsClang=YES
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_DEFINE([CC_LLVM_BACKEND], [1], [Define (to 1) if C compiler has an LLVM back end])
CcLlvmBackend=YES
AC_MSG_RESULT([yes])
else
CcLlvmBackend=NO
AC_MSG_RESULT([no])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [1])
AC_MSG_RESULT([yes])
else
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [0])
AC_MSG_RESULT([no])
fi
fi
AC_SUBST(GccIsClang)
AC_SUBST(CcLlvmBackend)
rm -f conftest.txt
])
......
This diff is collapsed.
......@@ -93,7 +93,7 @@ tracePm herald doc = do
-- | Generate a fresh `Id` of a given type
mkPmId :: Type -> DsM Id
mkPmId ty = getUniqueM >>= \unique ->
let occname = mkVarOccFS $ fsLit "$pm"
let occname = mkVarOccFS $ fsLit "pm"
name = mkInternalName unique occname noSrcSpan
in return (mkLocalId name ty)
......@@ -1576,8 +1576,8 @@ addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta)
= do { arg_ids <- traverse bind_expr args
; data_con_app x dc arg_ids }
-- See Note [Detecting pattern synonym applications in expressions]
| Var y <- e, not (isDataConWorkId x)
-- We don't consider (unsaturated!) DataCons as flexible variables
| Var y <- e, Nothing <- isDataConId_maybe x
-- We don't consider DataCons flexible variables
= modifyT (\delta -> addVarVarCt delta (x, y))
| otherwise
-- Any other expression. Try to find other uses of a semantically
......@@ -1635,9 +1635,9 @@ Compared to the situation where P and Q are DataCons, the lack of generativity
means we could never flag Q as redundant.
(also see Note [Undecidable Equality for PmAltCons] in PmTypes.)
On the other hand, if we fail to recognise the pattern synonym, we flag the
pattern match as incomplete. That wouldn't happen if had knowledge about the
scrutinee, in which case the oracle basically knows "If it's a P, then its field
is 15".
pattern match as inexhaustive. That wouldn't happen if we had knowledge about
the scrutinee, in which case the oracle basically knows "If it's a P, then its
field is 15".
This is a pretty narrow use case and I don't think we should to try to fix it
until a user complains energetically.
......
......@@ -631,6 +631,7 @@ emitBlackHoleCode node = do
-- work with profiling.
when eager_blackholing $ do
whenUpdRemSetEnabled dflags $ emitUpdRemSetPushThunk node
emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
-- See Note [Heap memory barriers] in SMP.h.
emitPrimCall [] MO_WriteBarrier []
......
......@@ -42,6 +42,7 @@ import BlockId
import MkGraph
import StgSyn
import Cmm
import Module ( rtsUnitId )
import Type ( Type, tyConAppTyCon )
import TyCon
import CLabel
......@@ -339,14 +340,20 @@ dispatchPrimop dflags = \case
emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
WriteMutVarOp -> \[mutv, var] -> OpDest_AllDone $ \res@[] -> do
old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)
emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
-- Without this write barrier, other CPUs may see this pointer before
-- the writes for the closure it points to have occurred.
-- Note that this also must come after we read the old value to ensure
-- that the read of old_val comes before another core's write to the
-- MutVar's value.
emitPrimCall res MO_WriteBarrier []
emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
[(baseExpr, AddrHint), (mutv,AddrHint)]
[(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
......@@ -1983,17 +1990,21 @@ doWritePtrArrayOp :: CmmExpr
doWritePtrArrayOp addr idx val
= do dflags <- getDynFlags
let ty = cmmExprType dflags val
hdr_size = arrPtrsHdrSize dflags
-- Update remembered set for non-moving collector
whenUpdRemSetEnabled dflags
$ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)
-- This write barrier is to ensure that the heap writes to the object
-- referred to by val have happened before we write val into the array.
-- See #12469 for details.
emitPrimCall [] MO_WriteBarrier []
mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val
mkBasicIndexedWrite hdr_size Nothing addr ty idx val
emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
-- the write barrier. We must write a byte into the mark table:
-- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
-- the write barrier. We must write a byte into the mark table:
-- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
emit $ mkStore (
cmmOffsetExpr dflags
(cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
(cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)
(loadArrPtrsSize dflags addr))
(CmmMachOp (mo_wordUShr dflags) [idx,
mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])
......@@ -2584,6 +2595,9 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =
dst <- assignTempE dst0
dst_off <- assignTempE dst_off0
-- Nonmoving collector write barrier
emitCopyUpdRemSetPush dflags (arrPtrsHdrSizeW dflags) dst dst_off n
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
......@@ -2646,6 +2660,9 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n =
src <- assignTempE src0
dst <- assignTempE dst0
-- Nonmoving collector write barrier
emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSizeW dflags) dst dst_off n
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
......@@ -2774,6 +2791,12 @@ doWriteSmallPtrArrayOp :: CmmExpr
doWriteSmallPtrArrayOp addr idx val = do
dflags <- getDynFlags
let ty = cmmExprType dflags val
-- Update remembered set for non-moving collector
tmp <- newTemp ty
mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx
whenUpdRemSetEnabled dflags $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
emitPrimCall [] MO_WriteBarrier [] -- #12469
mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val
emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
......@@ -2953,3 +2976,31 @@ emitCtzCall res x width = do
[ res ]
(MO_Ctz width)
[ x ]
---------------------------------------------------------------------------
-- Pushing to the update remembered set
---------------------------------------------------------------------------
-- | Push a range of pointer-array elements that are about to be copied over to
-- the update remembered set.
emitCopyUpdRemSetPush :: DynFlags
-> WordOff -- ^ array header size
-> CmmExpr -- ^ destination array
-> CmmExpr -- ^ offset in destination array (in words)
-> Int -- ^ number of elements to copy
-> FCode ()
emitCopyUpdRemSetPush _dflags _hdr_size _dst _dst_off 0 = return ()
emitCopyUpdRemSetPush dflags hdr_size dst dst_off n =
whenUpdRemSetEnabled dflags $ do
updfr_off <- getUpdFrameOff
graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off []
emit graph
where
lbl = mkLblExpr $ mkPrimCallLabel
$ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId
args =
[ mkIntExpr dflags hdr_size
, dst
, dst_off
, mkIntExpr dflags n
]
......@@ -131,8 +131,8 @@ import DynFlags
-- Turgid imports for showTypeCategory
import PrelNames
import TcType
import Type
import TyCon
import Predicate
import Data.Maybe
import qualified Data.Char
......
......@@ -39,6 +39,11 @@ module GHC.StgToCmm.Utils (
mkWordCLit,
newStringCLit, newByteStringCLit,
blankWord,
-- * Update remembered set operations
whenUpdRemSetEnabled,
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
) where
#include "HsVersions.h"
......@@ -576,3 +581,40 @@ assignTemp' e
let reg = CmmLocal lreg
emitAssign reg e
return (CmmReg reg)
---------------------------------------------------------------------------
-- Pushing to the update remembered set
---------------------------------------------------------------------------
whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()
whenUpdRemSetEnabled dflags code = do
do_it <- getCode code
the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
emit the_if
where
enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags)
zero = zeroExpr dflags
is_enabled = cmmNeWord dflags enabled zero
-- | Emit code to add an entry to a now-overwritten pointer to the update
-- remembered set.
emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten
-> FCode ()
emitUpdRemSetPush ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushClosure_")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
False
emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
-> FCode ()
emitUpdRemSetPushThunk ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushThunk_")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
False
......@@ -1368,12 +1368,7 @@ cvtTypeKind ty_str ty
TupleT n
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> if n==1 then return (head normals) -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy noExtField
HsBoxedOrConstraintTuple normals)
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
-> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)
| otherwise
-> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
......@@ -1491,8 +1486,6 @@ cvtTypeKind ty_str ty
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> returnL (HsExplicitTupleTy noExtField normals)
......
......@@ -106,7 +106,9 @@ module BasicTypes(
IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,
SpliceExplicitFlag(..)
SpliceExplicitFlag(..),
TypeOrKind(..), isTypeLevel, isKindLevel
) where
import GhcPrelude
......@@ -1644,3 +1646,25 @@ data SpliceExplicitFlag
= ExplicitSplice | -- ^ <=> $(f x y)
ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression
deriving Data
{- *********************************************************************
* *
Types vs Kinds
* *
********************************************************************* -}
-- | Flag to see whether we're type-checking terms or kind-checking types
data TypeOrKind = TypeLevel | KindLevel
deriving Eq
instance Outputable TypeOrKind where
ppr TypeLevel = text "TypeLevel"
ppr KindLevel = text "KindLevel"
isTypeLevel :: TypeOrKind -> Bool
isTypeLevel TypeLevel = True
isTypeLevel KindLevel = False
isKindLevel :: TypeOrKind -> Bool
isKindLevel TypeLevel = False
isKindLevel KindLevel = True
......@@ -73,6 +73,7 @@ import FieldLabel
import Class
import Name
import PrelNames
import Predicate
import Var
import VarSet( emptyVarSet )
import Outputable
......
......@@ -73,9 +73,6 @@ module Id (
isConLikeId, isBottomingId, idIsFrom,
hasNoBinding,
-- ** Evidence variables
DictId, isDictId, isEvVar,
-- ** Join variables
JoinId, isJoinId, isJoinId_maybe, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
......@@ -129,7 +126,7 @@ import IdInfo
import BasicTypes
-- Imported and re-exported
import Var( Id, CoVar, DictId, JoinId,
import Var( Id, CoVar, JoinId,
InId, InVar,
OutId, OutVar,
idInfo, idDetails, setIdDetails, globaliseId, varType,
......@@ -584,20 +581,6 @@ isDeadBinder :: Id -> Bool
isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
| otherwise = False -- TyVars count as not dead
{-
************************************************************************
* *
Evidence variables
* *
************************************************************************
-}
isEvVar :: Var -> Bool
isEvVar var = isEvVarType (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
{-
************************************************************************
* *
......
{-
Describes predicates as they are considered by the solver.
-}
module Predicate (
Pred(..), classifyPredType,
isPredTy, isEvVarType,
-- Equality predicates
EqRel(..), eqRelRole,
isEqPrimPred, isEqPred,
getEqPredTys, getEqPredTys_maybe, getEqPredRole,
predTypeEqRel,
mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,
-- Class predicates
mkClassPred, isDictTy,
isClassPred, isEqPredClass, isCTupleClass,
getClassPredTys, getClassPredTys_maybe,
-- Implicit parameters
isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred,
-- Evidence variables
DictId, isEvVar, isDictId
) where
import GhcPrelude
import Type
import Class
import TyCon
import Var
import Coercion
import PrelNames
import FastString
import Outputable
import Util
import Control.Monad ( guard )
-- | A predicate in the solver. The solver tries to prove Wanted predicates
-- from Given ones.
data Pred
= ClassPred Class [Type]
| EqPred EqRel Type Type
| IrredPred PredType
| ForAllPred [TyCoVarBinder] [PredType] PredType
-- ForAllPred: see Note [Quantified constraints] in TcCanonical
-- NB: There is no TuplePred case
-- Tuple predicates like (Eq a, Ord b) are just treated
-- as ClassPred, as if we had a tuple class with two superclasses
-- class (c1, c2) => (%,%) c1 c2
classifyPredType :: PredType -> Pred
classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
Just (tc, [_, _, ty1, ty2])
| tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2
| tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2
Just (tc, tys)
| Just clas <- tyConClass_maybe tc
-> ClassPred clas tys
_ | (tvs, rho) <- splitForAllVarBndrs ev_ty
, (theta, pred) <- splitFunTys rho
, not (null tvs && null theta)
-> ForAllPred tvs theta pred
| otherwise
-> IrredPred ev_ty
-- --------------------- Dictionary types ---------------------------------
mkClassPred :: Class -> [Type] -> PredType
mkClassPred clas tys = mkTyConApp (classTyCon clas) tys
isDictTy :: Type -> Bool
isDictTy = isClassPred
getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
getClassPredTys ty = case getClassPredTys_maybe ty of
Just (clas, tys) -> (clas, tys)
Nothing -> pprPanic "getClassPredTys" (ppr ty)
getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
getClassPredTys_maybe ty = case splitTyConApp_maybe ty of
Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)
_ -> Nothing
-- --------------------- Equality predicates ---------------------------------
-- | A choice of equality relation. This is separate from the type 'Role'
-- because 'Phantom' does not define a (non-trivial) equality relation.
data EqRel = NomEq | ReprEq
deriving (Eq, Ord)
instance Outputable EqRel where
ppr NomEq = text "nominal equality"
ppr ReprEq = text "representational equality"
eqRelRole :: EqRel -> Role
eqRelRole NomEq = Nominal
eqRelRole ReprEq = Representational
getEqPredTys :: PredType -> (Type, Type)
getEqPredTys ty
= case splitTyConApp_maybe ty of
Just (tc, [_, _, ty1, ty2])
| tc `hasKey` eqPrimTyConKey
|| tc `hasKey` eqReprPrimTyConKey
-> (ty1, ty2)
_ -> pprPanic "getEqPredTys" (ppr ty)
getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)
getEqPredTys_maybe ty
= case splitTyConApp_maybe ty of
Just (tc, [_, _, ty1, ty2])
| tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2)
| tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2)
_ -> Nothing
getEqPredRole :: PredType -> Role
getEqPredRole ty = eqRelRole (predTypeEqRel ty)
-- | Get the equality relation relevant for a pred type.
predTypeEqRel :: PredType -> EqRel
predTypeEqRel ty
| Just (tc, _) <- splitTyConApp_maybe ty
, tc `hasKey` eqReprPrimTyConKey
= ReprEq
| otherwise
= NomEq
{-------------------------------------------
Predicates on PredType
--------------------------------------------}
{-
Note [Evidence for quantified constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The superclass mechanism in TcCanonical.makeSuperClasses risks
taking a quantified constraint like
(forall a. C a => a ~ b)
and generate superclass evidence
(forall a. C a => a ~# b)
This is a funny thing: neither isPredTy nor isCoVarType are true
of it. So we are careful not to generate it in the first place:
see Note [Equality superclasses in quantified constraints]
in TcCanonical.
-}
isEvVarType :: Type -> Bool
-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)
-- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)
-- See Note [Types for coercions, predicates, and evidence] in TyCoRep
-- See Note [Evidence for quantified constraints]
isEvVarType ty = isCoVarType ty || isPredTy ty
isEqPredClass :: Class -> Bool
-- True of (~) and (~~)
isEqPredClass cls = cls `hasKey` eqTyConKey
|| cls `hasKey` heqTyConKey
isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool
isClassPred ty = case tyConAppTyCon_maybe ty of
Just tyCon | isClassTyCon tyCon -> True
_ -> False
isEqPred ty -- True of (a ~ b) and (a ~~ b)
-- ToDo: should we check saturation?
| Just tc <- tyConAppTyCon_maybe ty
, Just cls <- tyConClass_maybe tc
= isEqPredClass cls
| otherwise
= False
isEqPrimPred ty = isCoVarType ty
-- True of (a ~# b) (a ~R# b)
isIPPred ty = case tyConAppTyCon_maybe ty of
Just tc -> isIPTyCon tc
_ -> False
isIPTyCon :: TyCon -> Bool
isIPTyCon tc = tc `hasKey` ipClassKey
-- Class and its corresponding TyCon have the same Unique
isIPClass :: Class -> Bool
isIPClass cls = cls `hasKey` ipClassKey
isCTupleClass :: Class -> Bool
isCTupleClass cls = isTupleTyCon (classTyCon cls)
isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe ty =
do (tc,[t1,t2]) <- splitTyConApp_maybe ty
guard (isIPTyCon tc)
x <- isStrLitTy t1
return (x,t2)
hasIPPred :: PredType -> Bool
hasIPPred pred
= case classifyPredType pred of
ClassPred cls tys
| isIPClass cls -> True
| isCTupleClass cls -> any hasIPPred tys
_other -> False
{-
************************************************************************
* *
Evidence variables
* *
************************************************************************
-}
isEvVar :: Var -> Bool
isEvVar var = isEvVarType (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (varType id)
......@@ -40,6 +40,7 @@ module CLabel (
mkAsmTempDieLabel,
mkDirty_MUT_VAR_Label,
mkNonmovingWriteBarrierEnabledLabel,
mkUpdInfoLabel,
mkBHUpdInfoLabel,
mkIndStaticInfoLabel,
......@@ -484,7 +485,9 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
-- See Note [Proc-point local block entry-point].
-- Constructing Cmm Labels
mkDirty_MUT_VAR_Label, mkUpdInfoLabel,
mkDirty_MUT_VAR_Label,
mkNonmovingWriteBarrierEnabledLabel,
mkUpdInfoLabel,
mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
mkMAP_DIRTY_infoLabel,
......@@ -494,6 +497,8 @@ mkDirty_MUT_VAR_Label, mkUpdInfoLabel,
mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkNonmovingWriteBarrierEnabledLabel
= CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData
mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo
mkBHUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" ) CmmInfo
mkIndStaticInfoLabel = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC") CmmInfo
......
......@@ -6,8 +6,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
-- and Norman Ramsey
......@@ -108,6 +106,7 @@ analyzeCmm
-> FactBase f
-> FactBase f
analyzeCmm dir lattice transfer cmmGraph initFact =
{-# SCC analyzeCmm #-}
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap =
......@@ -169,7 +168,7 @@ rewriteCmm
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm dir lattice rwFun cmmGraph initFact = do
rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap1 =
......
......@@ -30,6 +30,7 @@ import VarEnv
import Id
import Type
import TyCon ( initRecTc, checkRecTc )
import Predicate ( isDictTy )
import Coercion
import BasicTypes
import Unique
......@@ -517,7 +518,7 @@ mk_cheap_fn dflags cheap_app
= \e mb_ty -> exprIsCheapX cheap_app e
|| case mb_ty of
Nothing -> False
Just ty -> isDictLikeTy ty
Just ty -> isDictTy ty
----------------------
......@@ -624,9 +625,6 @@ The (foo DInt) is floated out, and makes ineffective a RULE
One could go further and make exprIsCheap reply True to any
dictionary-typed expression, but that's more work.
See Note [Dictionary-like types] in TcType.hs for why we use
isDictLikeTy here rather than isDictTy
Note [Eta expanding thunks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't eta-expand
......
......@@ -77,6 +77,7 @@ import Id
import IdInfo
import PrelNames( absentErrorIdKey )
import Type
import Predicate
import TyCoRep( TyCoBinder(..), TyBinder )
import Coercion
import TyCon
......
......@@ -1071,7 +1071,7 @@ noFVs = emptyOccEnv
-- to filter additions to the latter. This gives us complete control
-- over what free variables we track.
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
deriving (Functor)
-- a combination of a state monad (TickTransState) and a writer
-- monad (FreeVars).
......
......@@ -327,7 +327,7 @@ dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
fail_expr <- mkFailExpr ProcExpr env_stk_ty
var <- selectSimpleMatchVarL pat
match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
let pat_ty = hsLPatType pat
let pat_ty = hsPatType pat
let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
(Lam var match_code)
core_cmd
......@@ -868,7 +868,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
let pat_ty = hsLPatType pat
let pat_ty = hsPatType pat
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
let pat_vars = mkVarSet (collectPatBinders pat)
let
......
......@@ -41,6 +41,7 @@ import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import Digraph
import Predicate
import PrelNames
import TyCon
......
module DsBinds where
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
import TcEvidence (HsWrapper)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
......@@ -930,7 +930,7 @@ dsDo stmts
(pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
do_arg (XApplicativeArg nec) = noExtCon nec
arg_tys = map hsLPatType pats
arg_tys = map hsPatType pats
; rhss' <- sequence rhss
......
......@@ -279,7 +279,7 @@ deBindComp pat core_list1 quals core_list2 = do
let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
let u2_ty = hsLPatType pat
let u2_ty = hsPatType pat
let res_ty = exprType core_list2
h_ty = u1_ty `mkVisFunTy` res_ty
......@@ -373,7 +373,7 @@ dfBindComp :: Id -> Id -- 'c' and 'n'
-> DsM CoreExpr
dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
let x_ty = hsPatType pat
let b_ty = idType n_id
-- create some new local id's
......
......@@ -672,7 +672,7 @@ mkSelectorBinds ticks pat val_expr
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
= do { let pat_ty = hsLPatType pat'
= do { let pat_ty = hsPatType pat'
; val_var <- newSysLocalDsNoLP pat_ty
; let mk_bind tick bndr_var
......@@ -758,7 +758,7 @@ mkLHsPatTup lpats = cL (getLoc (head lpats)) $
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
......
......@@ -214,6 +214,7 @@ Library
Hooks
Id
IdInfo
Predicate
Lexeme
Literal
Llvm
......@@ -505,6 +506,8 @@ Library
TcRnExports
TcRnMonad
TcRnTypes
Constraint
TcOrigin
TcRules
TcSimplify
TcHoleErrors
......@@ -593,6 +596,7 @@ Library
Instruction
BlockLayout
CFG
Dominators
Format
Reg
RegClass
......
......@@ -10,6 +10,7 @@
-- | Binary interface file support.
module BinIface (
-- * Public API for interface file serialisation
writeBinIface,
readBinIface,
getSymtabName,
......@@ -17,7 +18,16 @@ module BinIface (
CheckHiWay(..),
TraceBinIFaceReading(..),
getWithUserData,
putWithUserData
putWithUserData,
-- * Internal serialisation functions
getSymbolTable,
putName,
putDictionary,
putFastString,
putSymbolTable,
BinSymbolTable(..),
BinDictionary(..)
) where
......
......@@ -311,6 +311,7 @@ import GhcMonad
import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import LoadIface ( loadSysInterface )
import TcRnTypes
import Predicate
import Packages
import NameSet
import RdrName
......
......@@ -63,6 +63,9 @@ import TyCon
import Type hiding( typeKind )
import RepType
import TcType
import Constraint
import TcOrigin
import Predicate
import Var
import Id
import Name hiding ( varName )
......
......@@ -558,12 +558,11 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(cmmTopCodeGen ncgImpl)
fileIds dbgMap opt_cmm cmmCfg
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (pprNatCmmDecl ncgImpl) native)
dumpIfSet_dyn dflags
when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Weights"
(pprEdgeWeights nativeCfgWeights)
......@@ -679,19 +678,20 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
addNodesBetween nativeCfgWeights cfgRegAllocUpdates
(\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
let postRegCFG =
foldl' (\m (from,to) -> addImmediateSuccessor from to m )
cfgWithFixupBlks stack_updt_blks
pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))
<*> cfgWithFixupBlks
<*> pure stack_updt_blks
---- generate jump tables
let tabled =
{-# SCC "generateJumpTables" #-}
generateJumpTables ncgImpl alloced
dumpIfSet_dyn dflags
when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Update information"
( text "stack:" <+> ppr stack_updt_blks $$
text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
......@@ -701,12 +701,14 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "shortcutBranches" #-}
shortcutBranches dflags ncgImpl tabled postRegCFG
let optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG
let optimizedCFG :: Maybe CFG
optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG
dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Final Weights"
( pprEdgeWeights optimizedCFG )
maybe (return ()) (\cfg->
dumpIfSet_dyn dflags Opt_D_dump_cfg_weights "CFG Final Weights"
( pprEdgeWeights cfg ))
optimizedCFG
--TODO: Partially check validity of the cfg.
let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
......@@ -716,7 +718,8 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
let blocks = concatMap getBlks shorted
let labels = setFromList $ fmap blockId blocks :: LabelSet
return $! seq (sanityCheckCfg optimizedCFG labels $
let cfg = fromJust optimizedCFG
return $! seq (sanityCheckCfg cfg labels $
text "cfg not in lockstep") ()
---- sequence blocks
......@@ -734,7 +737,9 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "invertCondBranches" #-}
map invert sequenced
where
invertConds = (invertCondBranches ncgImpl) optimizedCFG
invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertConds = invertCondBranches ncgImpl optimizedCFG
invert top@CmmData {} = top
invert (CmmProc info lbl live (ListGraph blocks)) =
CmmProc info lbl live (ListGraph $ invertConds info blocks)
......@@ -884,13 +889,13 @@ shortcutBranches
:: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> CFG
-> ([NatCmmDecl statics instr],CFG)
-> Maybe CFG
-> ([NatCmmDecl statics instr],Maybe CFG)
shortcutBranches dflags ncgImpl tops weights
| gopt Opt_AsmShortcutting dflags
= ( map (apply_mapping ncgImpl mapping) tops'
, shortcutWeightMap weights mappingBid )
, shortcutWeightMap mappingBid <$!> weights )
| otherwise
= (tops, weights)
where
......
This diff is collapsed.
This diff is collapsed.
......@@ -88,7 +88,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-- the block's 'UnwindPoint's
-- See Note [What is this unwinding business?] in Debug
-- and Note [Unwinding information in the NCG] in this module.
invertCondBranches :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
invertCondBranches :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
-- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
-- when possible.
......
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-}
module RegAlloc.Graph.SpillCost (
SpillCostRecord,
plusSpillCostRecord,
......@@ -23,6 +23,7 @@ import Reg
import GraphBase
import Hoopl.Collections (mapLookup)
import Hoopl.Label
import Cmm
import UniqFM
import UniqSet
......@@ -49,9 +50,6 @@ type SpillCostRecord
type SpillCostInfo
= UniqFM SpillCostRecord
-- | Block membership in a loop
type LoopMember = Bool
type SpillCostState = State (UniqFM SpillCostRecord) ()
-- | An empty map of spill costs.
......@@ -88,45 +86,49 @@ slurpSpillCostInfo platform cfg cmm
where
countCmm CmmData{} = return ()
countCmm (CmmProc info _ _ sccs)
= mapM_ (countBlock info)
= mapM_ (countBlock info freqMap)
$ flattenSCCs sccs
where
LiveInfo _ entries _ _ = info
freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg
-- Lookup the regs that are live on entry to this block in
-- the info table from the CmmProc.
countBlock info (BasicBlock blockId instrs)
countBlock info freqMap (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive _ <- info
, Just rsLiveEntry <- mapLookup blockId blockLive
, rsLiveEntry_virt <- takeVirtuals rsLiveEntry
= countLIs (loopMember blockId) rsLiveEntry_virt instrs
= countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs
| otherwise
= error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs _ _ []
= return ()
-- Skip over comment and delta pseudo instrs.
countLIs inLoop rsLive (LiveInstr instr Nothing : lis)
countLIs scale rsLive (LiveInstr instr Nothing : lis)
| isMetaInstr instr
= countLIs inLoop rsLive lis
= countLIs scale rsLive lis
| otherwise
= pprPanic "RegSpillCost.slurpSpillCostInfo"
$ text "no liveness information on instruction " <> ppr instr
countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)
countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)
= do
-- Increment the lifetime counts for regs live on entry to this instr.
mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry
mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
-- Increment counts for what regs were read/written from.
let (RU read written) = regUsageOfInstr platform instr
mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written
mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written
-- Compute liveness for entry to next instruction.
let liveDieRead_virt = takeVirtuals (liveDieRead live)
......@@ -140,21 +142,18 @@ slurpSpillCostInfo platform cfg cmm
= (rsLiveAcross `unionUniqSets` liveBorn_virt)
`minusUniqSet` liveDieWrite_virt
countLIs inLoop rsLiveNext lis
countLIs scale rsLiveNext lis
loopCount inLoop
| inLoop = 10
| otherwise = 1
incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)
incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
loopBlocks = CFG.loopMembers <$> cfg
loopMember bid
| Just isMember <- join (mapLookup bid <$> loopBlocks)
= isMember
blockFreq :: Maybe (LabelMap Double) -> Label -> Double
blockFreq freqs bid
| Just freq <- join (mapLookup bid <$> freqs)
= max 1.0 (10000 * freq)
| otherwise
= False
= 1.0 -- Only if no cfg given
-- | Take all the virtual registers from this set.
takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
......@@ -215,31 +214,39 @@ chooseSpill info graph
-- Without live range splitting, its's better to spill from the outside
-- in so set the cost of very long live ranges to zero
--
{-
spillCost_chaitin
:: SpillCostInfo
-> Graph Reg RegClass Reg
-> Reg
-> Float
spillCost_chaitin info graph reg
-- Spilling a live range that only lives for 1 instruction
-- isn't going to help us at all - and we definitely want to avoid
-- trying to re-spill previously inserted spill code.
| lifetime <= 1 = 1/0
-- It's unlikely that we'll find a reg for a live range this long
-- better to spill it straight up and not risk trying to keep it around
-- and have to go through the build/color cycle again.
| lifetime > allocatableRegsInClass (regClass reg) * 10
= 0
-- spillCost_chaitin
-- :: SpillCostInfo
-- -> Graph VirtualReg RegClass RealReg
-- -> VirtualReg
-- -> Float
-- spillCost_chaitin info graph reg
-- -- Spilling a live range that only lives for 1 instruction
-- -- isn't going to help us at all - and we definitely want to avoid
-- -- trying to re-spill previously inserted spill code.