...
 
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))
......
......@@ -8,7 +8,7 @@ See Note [Core Lint guarantee].
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-}
module GHC.Core.Lint (
lintCoreBindings, lintUnfolding,
......@@ -33,7 +33,6 @@ import GHC.Core.Op.Monad
import Bag
import Literal
import GHC.Core.DataCon
import TysWiredIn
import TysPrim
import TcType ( isFloatingTy )
import Var
......@@ -461,14 +460,17 @@ lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc,
lintCoreBindings dflags pass local_in_scope binds
= initL dflags flags local_in_scope $
addLoc TopLevelBindings $
lintLetBndrs TopLevel binders $
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
do { checkL (null dups) (dupVars dups)
; checkL (null ext_dups) (dupExtVars ext_dups)
; mapM lint_bind binds }
; lintRecBindings TopLevel all_pairs $
return () }
where
all_pairs = flattenBinds binds
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'; see Note [Glomming] in OccurAnal
binders = map fst all_pairs
flags = defaultLintFlags
{ lf_check_global_ids = check_globals
, lf_check_inline_loop_breakers = check_lbs
......@@ -494,7 +496,6 @@ lintCoreBindings dflags pass local_in_scope binds
CorePrep -> AllowAtTopLevel
_ -> AllowAnywhere
binders = bindersOfBinds binds
(_, dups) = removeDups compare binders
-- dups_ext checks for names with different uniques
......@@ -509,11 +510,6 @@ lintCoreBindings dflags pass local_in_scope binds
= compare (m1, nameOccName n1) (m2, nameOccName n2)
| otherwise = LT
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
{-
************************************************************************
* *
......@@ -576,28 +572,32 @@ lintExpr dflags vars expr
Check a core binding, returning the list of variables bound.
-}
lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
do { ty <- lintRhs binder rhs
; binder_ty <- applySubstTy (idType binder)
; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
-> LintM a -> LintM a
lintRecBindings top_lvl pairs thing_inside
= lintIdBndrs top_lvl bndrs $ \ bndrs' ->
do { zipWithM_ lint_pair bndrs' rhss
; thing_inside }
where
(bndrs, rhss) = unzip pairs
lint_pair bndr' rhs
= addLoc (RhsOf bndr') $
do { rhs_ty <- lintRhs bndr' rhs -- Check the rhs
; lintLetBind top_lvl Recursive bndr' rhs rhs_ty }
lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
-> CoreExpr -> LintedType -> LintM ()
-- Binder's type, and the RHS, have already been linted
-- This function checks other invariants
lintLetBind top_lvl rec_flag binder rhs rhs_ty
= do { let binder_ty = idType binder
; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)
-- If the binding is for a CoVar, the RHS should be (Coercion co)
-- See Note [Core type and coercion invariant] in GHC.Core
; checkL (not (isCoVar binder) || isCoArg rhs)
(mkLetErr binder rhs)
-- Check that it's not levity-polymorphic
-- Do this first, because otherwise isUnliftedType panics
-- Annoyingly, this duplicates the test in lintIdBdr,
-- because for non-rec lets we call lintSingleBinding first
; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))
(badBndrTyMsg binder (text "levity-polymorphic"))
-- Check the let/app invariant
-- See Note [Core let/app invariant] in GHC.Core
; checkL ( isJoinId binder
......@@ -610,14 +610,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- demanded. Primitive string literals are exempt as there is no
-- computation to perform, see Note [Core top-level string literals].
; checkL (not (isStrictId binder)
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
|| (isNonRec rec_flag && not (isTopLevel top_lvl))
|| exprIsTickedString rhs)
(mkStrictMsg binder)
-- Check that if the binder is at the top level and has type Addr#,
-- that it is a string literal, see
-- Note [Core top-level string literals].
; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy)
|| exprIsTickedString rhs)
(mkTopNonLitStrMsg binder)
......@@ -674,7 +674,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- join point.
--
-- See Note [Checking StaticPtrs].
lintRhs :: Id -> CoreExpr -> LintM OutType
lintRhs :: Id -> CoreExpr -> LintM LintedType
-- NB: the Id can be Linted or not -- it's only used for
-- its OccInfo and join-pointer-hood
lintRhs bndr rhs
| Just arity <- isJoinId_maybe bndr
= lint_join_lams arity arity True rhs
......@@ -761,13 +763,14 @@ hurts us here.
************************************************************************
-}
-- For OutType, OutKind, the substitution has been applied,
-- but has not been linted yet
type LintedType = Type -- Substitution applied, and type is linted
type LintedKind = Kind
-- Linted things: substitution applied, and type is linted
type LintedType = Type
type LintedKind = Kind
type LintedCoercion = Coercion
type LintedTyCoVar = TyCoVar
type LintedId = Id
lintCoreExpr :: CoreExpr -> LintM OutType
lintCoreExpr :: CoreExpr -> LintM LintedType
-- The returned type has the substitution from the monad
-- already applied to it:
-- lintCoreExpr e subst = exprType (subst e)
......@@ -776,18 +779,20 @@ lintCoreExpr :: CoreExpr -> LintM OutType
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintCoreExpr (Var var)
= lintVarOcc var 0
= lintIdOcc var 0
lintCoreExpr (Lit lit)
= return (literalType lit)
lintCoreExpr (Cast expr co)
= do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
; co' <- applySubstCo co
; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
; checkValueKind k2 (text "target of cast" <+> quotes (ppr co))
; lintRole co' Representational r
; co' <- lintCoercion co
; let (Pair from_ty to_ty, role) = coercionKindRole co'
; checkValueType to_ty $
text "target of cast" <+> quotes (ppr co')
; lintRole co' Representational role
; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
; return to_ty }
......@@ -809,7 +814,7 @@ lintCoreExpr (Tick tickish expr)
lintCoreExpr (Let (NonRec tv (Type ty)) body)
| isTyVar tv
= -- See Note [Linting type lets]
do { ty' <- applySubstTy ty
do { ty' <- lintType ty
; lintTyBndr tv $ \ tv' ->
do { addLoc (RhsOf tv) $ lintTyKind tv' ty'
-- Now extend the substitution so we
......@@ -820,33 +825,34 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
lintCoreExpr (Let (NonRec bndr rhs) body)
| isId bndr
= do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
; addLoc (BodyOfLetRec [bndr])
(lintBinder LetBind bndr $ \_ ->
addGoodJoins [bndr] $
lintCoreExpr body) }
= do { -- First Lint the RHS, before bringing the binder into scope
rhs_ty <- lintRhs bndr rhs
-- Now lint the binder
; lintBinder LetBind bndr $ \bndr' ->
do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
; addLoc (BodyOfLetRec [bndr]) (lintCoreExpr body) } }
| otherwise
= failWithL (mkLetErr bndr rhs) -- Not quite accurate
lintCoreExpr e@(Let (Rec pairs) body)
= lintLetBndrs NotTopLevel bndrs $
addGoodJoins bndrs $
do { -- Check that the list of pairs is non-empty
= do { -- Check that the list of pairs is non-empty
checkL (not (null pairs)) (emptyRec e)
-- Check that there are no duplicated binders
; let (_, dups) = removeDups compare bndrs
; checkL (null dups) (dupVars dups)
-- Check that either all the binders are joins, or none
; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
mkInconsistentRecMsg bndrs
mkInconsistentRecMsg bndrs
; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
; lintRecBindings NotTopLevel pairs $
addLoc (BodyOfLetRec bndrs) $
lintCoreExpr body }
where
bndrs = map fst pairs
(_, dups) = removeDups compare bndrs
lintCoreExpr e@(App _ _)
= do { fun_ty <- lintCoreFun fun (length args)
......@@ -867,23 +873,35 @@ lintCoreExpr (Type ty)
= failWithL (text "Type found as expression" <+> ppr ty)
lintCoreExpr (Coercion co)
= do { (k1, k2, ty1, ty2, role) <- lintInCo co
; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }
= do { co' <- addLoc (InCo co) $
lintCoercion co
; return (coercionType co') }
----------------------
lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
-> LintM Type -- returns type of the *variable*
lintVarOcc var nargs
= do { checkL (isNonCoVarId var)
lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed
-> LintM LintedType -- returns type of the *variable*
lintIdOcc var nargs
= addLoc (OccOf var) $
do { checkL (isNonCoVarId var)
(text "Non term variable" <+> ppr var)
-- See GHC.Core Note [Variable occurrences in Core]
-- Check that the type of the occurrence is the same
-- as the type of the binding site
; ty <- applySubstTy (idType var)
; var' <- lookupIdInScope var
; let ty' = idType var'
; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty
-- as the type of the binding site. The inScopeIds are
-- /un-substituted/, so this checks that the occurrence type
-- is identical to the binder type.
-- This makes things much easier for things like:
-- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...
-- The "::Maybe a" on the occurrence is referring to the /outer/ a.
-- If we compared /substituted/ types we'd risk comparing
-- (Maybe a) from the binding site with bogus (Maybe a1) from
-- the occurrence site. Comparing un-substituted types finesses
-- this altogether
; (bndr, linted_bndr_ty) <- lookupIdInScope var
; let occ_ty = idType var
bndr_ty = idType bndr
; ensureEqTys occ_ty bndr_ty $
mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty
-- Check for a nested occurrence of the StaticPtr constructor.
-- See Note [Checking StaticPtrs].
......@@ -895,13 +913,13 @@ lintVarOcc var nargs
; checkDeadIdOcc var
; checkJoinOcc var nargs
; return (idType var') }
; return linted_bndr_ty }
lintCoreFun :: CoreExpr
-> Int -- Number of arguments (type or val) being passed
-> LintM Type -- Returns type of the *function*
-> Int -- Number of arguments (type or val) being passed
-> LintM LintedType -- Returns type of the *function*
lintCoreFun (Var var) nargs
= lintVarOcc var nargs
= lintIdOcc var nargs
lintCoreFun (Lam var body) nargs
-- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see
......@@ -941,7 +959,9 @@ checkJoinOcc var n_args
= do { mb_join_arity_bndr <- lookupJoinId var
; case mb_join_arity_bndr of {
Nothing -> -- Binder is not a join point
addErrL (invalidJoinOcc var) ;
do { join_set <- getValidJoins
; addErrL (text "join set " <+> ppr join_set $$
invalidJoinOcc var) } ;
Just join_arity_bndr ->
......@@ -1038,15 +1058,15 @@ subtype of the required type, as one would expect.
-}
lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
lintCoreArgs :: LintedType -> [CoreArg] -> LintM LintedType
lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args
lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg :: LintedType -> CoreArg -> LintM LintedType
lintCoreArg fun_ty (Type arg_ty)
= do { checkL (not (isCoercionTy arg_ty))
(text "Unnecessary coercion-to-type injection:"
<+> ppr arg_ty)
; arg_ty' <- applySubstTy arg_ty
; arg_ty' <- lintType arg_ty
; lintTyApp fun_ty arg_ty' }
lintCoreArg fun_ty arg
......@@ -1060,11 +1080,12 @@ lintCoreArg fun_ty arg
; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
(mkLetAppMsg arg)
; lintValApp arg fun_ty arg_ty }
-----------------
lintAltBinders :: OutType -- Scrutinee type
-> OutType -- Constructor type
lintAltBinders :: LintedType -- Scrutinee type
-> LintedType -- Constructor type
-> [OutVar] -- Binders
-> LintM ()
-- If you edit this function, you may need to update the GHC formalism
......@@ -1080,7 +1101,7 @@ lintAltBinders scrut_ty con_ty (bndr:bndrs)
; lintAltBinders scrut_ty con_ty' bndrs }
-----------------
lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp :: LintedType -> LintedType -> LintM LintedType
lintTyApp fun_ty arg_ty
| Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
= do { lintTyKind tv arg_ty
......@@ -1094,7 +1115,7 @@ lintTyApp fun_ty arg_ty
= failWithL (mkTyAppMsg fun_ty arg_ty)
-----------------
lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType
lintValApp arg fun_ty arg_ty
| Just (arg,res) <- splitFunTy_maybe fun_ty
= do { ensureEqTys arg arg_ty err1
......@@ -1105,17 +1126,17 @@ lintValApp arg fun_ty arg_ty
err1 = mkAppMsg fun_ty arg_ty arg
err2 = mkNonFunAppMsg fun_ty arg_ty arg
lintTyKind :: OutTyVar -> OutType -> LintM ()
lintTyKind :: OutTyVar -> LintedType -> LintM ()
-- Both args have had substitution applied
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintTyKind tyvar arg_ty
= do { arg_kind <- lintType arg_ty
; unless (arg_kind `eqType` tyvar_kind)
(addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) }
= unless (arg_kind `eqType` tyvar_kind) $
addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))
where
tyvar_kind = tyVarKind tyvar
arg_kind = typeKind arg_ty
{-
************************************************************************
......@@ -1125,7 +1146,7 @@ lintTyKind tyvar arg_ty
************************************************************************
-}
lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM OutType
lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM LintedType
lintCaseExpr scrut var alt_ty alts =
do { let e = Case scrut var alt_ty alts -- Just for error messages
......@@ -1134,10 +1155,10 @@ lintCaseExpr scrut var alt_ty alts =
-- See Note [Join points are less general than the paper]
-- in GHC.Core
; (alt_ty, _) <- addLoc (CaseTy scrut) $
lintInTy alt_ty
; (var_ty, _) <- addLoc (IdTy var) $
lintInTy (idType var)
; alt_ty <- addLoc (CaseTy scrut) $
lintValueType alt_ty
; var_ty <- addLoc (IdTy var) $
lintValueType (idType var)
-- We used to try to check whether a case expression with no
-- alternatives was legitimate, but this didn't work.
......@@ -1179,7 +1200,7 @@ lintCaseExpr scrut var alt_ty alts =
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
-- b1) Check that the DEFAULT comes first, if it exists
-- b2) Check that the others are in increasing order
......@@ -1219,14 +1240,14 @@ checkCaseAlts e ty alts =
Nothing -> False
Just tycon -> isPrimTyCon tycon
lintAltExpr :: CoreExpr -> OutType -> LintM ()
lintAltExpr :: CoreExpr -> LintedType -> LintM ()
lintAltExpr expr ann_ty
= do { actual_ty <- lintCoreExpr expr
; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
-- See GHC.Core Note [Case expression invariants] item (6)
lintCoreAlt :: OutType -- Type of scrutinee
-> OutType -- Type of the alternative
lintCoreAlt :: LintedType -- Type of scrutinee
-> LintedType -- Type of the alternative
-> CoreAlt
-> LintM ()
-- If you edit this function, you may need to update the GHC formalism
......@@ -1286,40 +1307,43 @@ lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->
-- See Note [GHC Formalism]
lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder site var linterF
| isTyVar var = lintTyBndr var linterF
| isCoVar var = lintCoBndr var linterF
| otherwise = lintIdBndr NotTopLevel site var linterF
| isTyCoVar var = lintTyCoBndr var linterF
| otherwise = lintIdBndr NotTopLevel site var linterF
lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
lintTyBndr tv thing_inside
= do { subst <- getTCvSubst
; let (subst', tv') = substTyVarBndr subst tv
; lintKind (varType tv')
; updateTCvSubst subst' (thing_inside tv') }
lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a
lintTyBndr = lintTyCoBndr -- We could specialise it, I guess
-- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a
-- lintCoBndr = lintTyCoBndr -- We could specialise it, I guess
lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a
lintCoBndr cv thing_inside
lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a
lintTyCoBndr tcv thing_inside
= do { subst <- getTCvSubst
; let (subst', cv') = substCoVarBndr subst cv
; lintKind (varType cv')
; lintL (isCoVarType (varType cv'))
(text "CoVar with non-coercion type:" <+> pprTyVar cv)
; updateTCvSubst subst' (thing_inside cv') }
lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a
lintLetBndrs top_lvl ids linterF
= go ids
; kind' <- lintType (varType tcv)
; let tcv' = uniqAway (getTCvInScope subst) $
setVarType tcv kind'
subst' = extendTCvSubstWithClone subst tcv tcv'
; when (isCoVar tcv) $
lintL (isCoVarType kind')
(text "CoVar with non-coercion type:" <+> pprTyVar tcv)
; updateTCvSubst subst' (thing_inside tcv') }
lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a
lintIdBndrs top_lvl ids thing_inside
= go ids thing_inside
where
go [] = linterF
go (id:ids) = lintIdBndr top_lvl LetBind id $ \_ ->
go ids
go :: [Id] -> ([Id] -> LintM a) -> LintM a
go [] thing_inside = thing_inside []
go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' ->
go ids $ \ids' ->
thing_inside (id' : ids')
lintIdBndr :: TopLevelFlag -> BindingSite
-> InVar -> (OutVar -> LintM a) -> LintM a
-- Do substitution on the type of a binder and add the var with this
-- new type to the in-scope set of the second argument
-- ToDo: lint its rules
lintIdBndr top_lvl bind_site id linterF
lintIdBndr top_lvl bind_site id thing_inside
= ASSERT2( isId id, ppr id )
do { flags <- getLintFlags
; checkL (not (lf_check_global_ids flags) || isLocalId id)
......@@ -1334,14 +1358,11 @@ lintIdBndr top_lvl bind_site id linterF
; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)
(mkNonTopExternalNameMsg id)
; (id_ty, k) <- addLoc (IdTy id) $
lintInTy (idType id)
; let id' = setIdType id id_ty
-- See Note [Levity polymorphism invariants] in GHC.Core
; lintL (isJoinId id || not (lf_check_levity_poly flags) || not (isKindLevPoly k))
(text "Levity-polymorphic binder:" <+>
(ppr id <+> dcolon <+> parens (ppr id_ty <+> dcolon <+> ppr k)))
; lintL (isJoinId id || not (lf_check_levity_poly flags)
|| not (isTypeLevPoly id_ty)) $
text "Levity-polymorphic binder:" <+> ppr id <+> dcolon <+>
parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty))
-- Check that a join-id is a not-top-level let-binding
; when (isJoinId id) $
......@@ -1353,8 +1374,13 @@ lintIdBndr top_lvl bind_site id linterF
; lintL (not (isCoVarType id_ty))
(text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)
; addInScopeId id' $ (linterF id') }
; linted_ty <- addLoc (IdTy id) (lintValueType id_ty)
; addInScopeId id linted_ty $
thing_inside (setIdType id linted_ty) }
where
id_ty = idType id
is_top_lvl = isTopLevel top_lvl
is_let_bind = case bind_site of
LetBind -> True
......@@ -1378,45 +1404,58 @@ lintTypes dflags vars tys
where
(_warns, errs) = initL dflags defaultLintFlags vars linter
linter = lintBinders LambdaBind vars $ \_ ->
mapM_ lintInTy tys
mapM_ lintType tys
lintInTy :: InType -> LintM (LintedType, LintedKind)
lintValueType :: Type -> LintM LintedType
-- Types only, not kinds
-- Check the type, and apply the substitution to it
-- See Note [Linting type lets]
lintInTy ty
lintValueType ty
= addLoc (InType ty) $
do { ty' <- applySubstTy ty
; k <- lintType ty'
; addLoc (InKind ty' k) $
lintKind k -- The kind returned by lintType is already
-- a LintedKind but we also want to check that
-- k :: *, which lintKind does
; return (ty', k) }
do { ty' <- lintType ty
; let sk = typeKind ty'
; lintL (classifiesTypeWithValues sk) $
hang (text "Ill-kinded type:" <+> ppr ty)
2 (text "has kind:" <+> ppr sk)
; return ty' }
checkTyCon :: TyCon -> LintM ()
checkTyCon tc
= checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
-------------------
lintType :: OutType -> LintM LintedKind
-- The returned Kind has itself been linted
lintType :: LintedType -> LintM LintedType
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintType (TyVarTy tv)
= do { checkL (isTyVar tv) (mkBadTyVarMsg tv)
; tv' <- lintTyCoVarInScope tv
; return (tyVarKind tv') }
-- We checked its kind when we added it to the envt
| not (isTyVar tv)
= failWithL (mkBadTyVarMsg tv)
| otherwise
= do { subst <- getTCvSubst
; case lookupTyVar subst tv of
Just linted_ty -> return linted_ty
-- In GHCi we may lint an expression with a free
-- type variable. Then it won't be in the
-- substitution, but it should be in scope
Nothing | tv `isInScope` subst
-> return (TyVarTy tv)
| otherwise
-> failWithL $
hang (text "The type variable" <+> pprBndr LetBind tv)
2 (text "is out of scope")
}
lintType ty@(AppTy t1 t2)
| TyConApp {} <- t1
= failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty
| otherwise
= do { k1 <- lintType t1
; k2 <- lintType t2
; lint_ty_app ty k1 [(t2,k2)] }
= do { t1' <- lintType t1
; t2' <- lintType t2
; lint_ty_app ty (typeKind t1') [t2']
; return (AppTy t1' t2') }
lintType ty@(TyConApp tc tys)
| isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
......@@ -1433,71 +1472,72 @@ lintType ty@(TyConApp tc tys)
| otherwise -- Data types, data families, primitive types
= do { checkTyCon tc
; ks <- mapM lintType tys
; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
; tys' <- mapM lintType tys
; lint_ty_app ty (tyConKind tc) tys'
; return (TyConApp tc tys') }
-- arrows can related *unlifted* kinds, so this has to be separate from
-- a dependent forall.
lintType ty@(FunTy _ t1 t2)
= do { k1 <- lintType t1
; k2 <- lintType t2
; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
lintType ty@(FunTy af t1 t2)
= do { t1' <- lintType t1
; t2' <- lintType t2
; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2'
; return (FunTy af t1' t2') }
lintType ty@(ForAllTy (Bndr tcv vis) body_ty)
| not (isTyCoVar tcv)
= failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty)
| otherwise
= lintTyCoBndr tcv $ \tcv' ->
do { body_ty' <- lintType body_ty
; lintForAllBody tcv' body_ty'
lintType t@(ForAllTy (Bndr tv _vis) ty)
-- forall over types
| isTyVar tv
= lintTyBndr tv $ \tv' ->
do { k <- lintType ty
; checkValueKind k (text "the body of forall:" <+> ppr t)
; case occCheckExpand [tv'] k of -- See Note [Stupid type synonyms]
Just k' -> return k'
Nothing -> failWithL (hang (text "Variable escape in forall:")
2 (vcat [ text "type:" <+> ppr t
, text "kind:" <+> ppr k ]))
}
; when (isCoVar tcv) $
lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $
text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)
-- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]
-- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo]
; return (ForAllTy (Bndr tcv' vis) body_ty') }
lintType t@(ForAllTy (Bndr cv _vis) ty)
-- forall over coercions
= do { lintL (isCoVar cv)
(text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t)
; lintL (cv `elemVarSet` tyCoVarsOfType ty)
(text "Covar does not occur in the body:" <+> ppr t)
; lintCoBndr cv $ \_ ->
do { k <- lintType ty
; checkValueKind k (text "the body of forall:" <+> ppr t)
; return liftedTypeKind
-- We don't check variable escape here. Namely, k could refer to cv'
}}
lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
lintType ty@(LitTy l)
= do { lintTyLit l; return ty }
lintType (CastTy ty co)
= do { k1 <- lintType ty
; (k1', k2) <- lintStarCoercion co
; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1)
; return k2 }
= do { ty' <- lintType ty
; co' <- lintStarCoercion co
; let tyk = typeKind ty'
cok = coercionLKind co'
; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok)
; return (CastTy ty' co') }
lintType (CoercionTy co)
= do { (k1, k2, ty1, ty2, r) <- lintCoercion co
; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }
{- Note [Stupid type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#14939)
type Alg cls ob = ob
f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b
Here 'cls' appears free in b's kind, which would usually be illegal
(because in (forall a. ty), ty's kind should not mention 'a'). But
#in this case (Alg cls *) = *, so all is well. Currently we allow
this, and make Lint expand synonyms where necessary to make it so.
c.f. TcUnify.occCheckExpand and GHC.Core.Utils.coreAltsType which deal
with the same problem. A single systematic solution eludes me.
-}
= do { co' <- lintCoercion co
; return (CoercionTy co') }
-----------------
lintForAllBody :: LintedTyCoVar -> LintedType -> LintM ()
-- Do the checks for the body of a forall-type
lintForAllBody tcv body_ty
= do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty)
-- For type variables, check for skolem escape
-- See Note [Phantom type variables in kinds] in GHC.Core.Type
-- The kind of (forall cv. th) is liftedTypeKind, so no
-- need to check for skolem-escape in the CoVar case
; let body_kind = typeKind body_ty
; when (isTyVar tcv) $
case occCheckExpand [tcv] body_kind of
Just {} -> return ()
Nothing -> failWithL $
hang (text "Variable escape in forall:")
2 (vcat [ text "tyvar:" <+> ppr tcv
, text "type:" <+> ppr body_ty
, text "kind:" <+> ppr body_kind ])
}
-----------------
lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind
lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType
-- The TyCon is a type synonym or a type family (not a data family)
-- See Note [Linting type synonym applications]
-- c.f. TcValidity.check_syn_tc_app
......@@ -1511,58 +1551,54 @@ lintTySynFamApp report_unsat ty tc tys
, let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
= do { -- Kind-check the argument types, but without reporting
-- un-saturated type families/synonyms
ks <- setReportUnsat False (mapM lintType tys)
tys' <- setReportUnsat False (mapM lintType tys)
; when report_unsat $
do { _ <- lintType expanded_ty
; return () }
; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
; lint_ty_app ty (tyConKind tc) tys'
; return (TyConApp tc tys') }
-- Otherwise this must be a type family
| otherwise
= do { ks <- mapM lintType tys
; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
-----------------
lintKind :: OutKind -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintKind k = do { sk <- lintType k
; unless (classifiesTypeWithValues sk)
(addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
2 (text "has kind:" <+> ppr sk))) }
= do { tys' <- mapM lintType tys
; lint_ty_app ty (tyConKind tc) tys'
; return (TyConApp tc tys') }
-----------------
-- Confirms that a type is really *, #, Constraint etc
checkValueKind :: OutKind -> SDoc -> LintM ()
checkValueKind k doc
= lintL (classifiesTypeWithValues k)
(text "Non-*-like kind when *-like expected:" <+> ppr k $$
checkValueType :: LintedType -> SDoc -> LintM ()
checkValueType ty doc
= lintL (classifiesTypeWithValues kind)
(text "Non-*-like kind when *-like expected:" <+> ppr kind $$
text "when checking" <+> doc)
where
kind = typeKind ty
-----------------
lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
lintArrow :: SDoc -> LintedType -> LintedType -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2
lintArrow what t1 t2 -- Eg lintArrow "type or kind `blah'" k1 k2
-- or lintArrow "coercion `blah'" k1 k2
= do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1))
; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2))
; return liftedTypeKind }
; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) }
where
k1 = typeKind t1
k2 = typeKind t2
msg ar k
= vcat [ hang (text "Ill-kinded" <+> ar)
2 (text "in" <+> what)
, what <+> text "kind:" <+> ppr k ]
-----------------
lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()
lint_ty_app ty k tys
= lint_app (text "type" <+> quotes (ppr ty)) k tys
----------------
lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()
lint_co_app ty k tys
= lint_app (text "coercion" <+> quotes (ppr ty)) k tys
......@@ -1574,42 +1610,45 @@ lintTyLit (NumTyLit n)
where msg = text "Negative type literal:" <+> integer n
lintTyLit (StrTyLit _) = return ()
lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM ()
-- (lint_app d fun_kind arg_tys)
-- We have an application (f arg_ty1 .. arg_tyn),
-- where f :: fun_kind
-- Takes care of linting the OutTypes
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lint_app doc kfn kas
lint_app doc kfn arg_tys
= do { in_scope <- getInScope
-- We need the in_scope set to satisfy the invariant in
-- Note [The substitution invariant] in GHC.Core.TyCo.Subst
; foldlM (go_app in_scope) kfn kas }
; _ <- foldlM (go_app in_scope) kfn arg_tys
; return () }
where
fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc
, nest 2 (text "Function kind =" <+> ppr kfn)
, nest 2 (text "Arg kinds =" <+> ppr kas)
, nest 2 (text "Arg types =" <+> ppr arg_tys)
, extra ]
go_app in_scope kfn tka
go_app in_scope kfn ta
| Just kfn' <- coreView kfn
= go_app in_scope kfn' tka
= go_app in_scope kfn' ta
go_app _ (FunTy _ kfa kfb) tka@(_,ka)
= do { unless (ka `eqType` kfa) $
addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))
go_app _ fun_kind@(FunTy _ kfa kfb) ta
= do { let ka = typeKind ta
; unless (ka `eqType` kfa) $
addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))
; return kfb }
go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka)
go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta
= do { let kv_kind = varType kv
ka = typeKind ta
; unless (ka `eqType` kv_kind) $
addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka)))
addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$
ppr ta <+> dcolon <+> ppr ka)))
; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn }
go_app _ kfn ka
= failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka)))
go_app _ kfn ta
= failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta)))
{- *********************************************************************
* *
......@@ -1617,7 +1656,7 @@ lint_app doc kfn kas
* *
********************************************************************* -}
lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()
lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM ()
lintCoreRule _ _ (BuiltinRule {})
= return () -- Don't bother
......@@ -1710,68 +1749,94 @@ Note [Rules and join points] in OccurAnal for further discussion.
************************************************************************
-}
lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
-- Check the coercion, and apply the substitution to it
-- See Note [Linting type lets]
lintInCo co
= addLoc (InCo co) $
do { co' <- applySubstCo co
; lintCoercion co' }
{- Note [Asymptotic efficiency]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When linting coercions (and types actually) we return a linted
(substituted) coercion. Then we often have to take the coercionKind of
that returned coercion. If we get long chains, that can be asymptotically
inefficient, notably in
* TransCo
* InstCo
* NthCo (cf #9233)
* LRCo
But the code is simple. And this is only Lint. Let's wait to see if
the bad perf bites us in practice.
A solution would be to return the kind and role of the coercion,
as well as the linted coercion. Or perhaps even *only* the kind and role,
which is what used to happen. But that proved tricky and error prone
(#17923), so now we return the coercion.
-}
-- lints a coercion, confirming that its lh kind and its rh kind are both *
-- also ensures that the role is Nominal
lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)
lintStarCoercion :: InCoercion -> LintM LintedCoercion
lintStarCoercion g
= do { (k1, k2, t1, t2, r) <- lintCoercion g
; checkValueKind k1 (text "the kind of the left type in" <+> ppr g)
; checkValueKind k2 (text "the kind of the right type in" <+> ppr g)
; lintRole g Nominal r
; return (t1, t2) }
lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
-- Check the kind of a coercion term, returning the kind
-- Post-condition: the returned OutTypes are lint-free
--
-- If lintCoercion co = (k1, k2, s1, s2, r)
-- then co :: s1 ~r s2
-- s1 :: k1
-- s2 :: k2
= do { g' <- lintCoercion g
; let Pair t1 t2 = coercionKind g'
; checkValueType t1 (text "the kind of the left type in" <+> ppr g)
; checkValueType t2 (text "the kind of the right type in" <+> ppr g)
; lintRole g Nominal (coercionRole g)
; return g' }
lintCoercion :: InCoercion -> LintM LintedCoercion
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
= failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)
2 (text "With offending type:" <+> ppr (varType cv)))
| otherwise
= do { subst <- getTCvSubst
; case lookupCoVar subst cv of
Just linted_co -> return linted_co ;
Nothing -> -- lintCoBndr always extends the substitition
failWithL $
hang (text "The coercion variable" <+> pprBndr LetBind cv)
2 (text "is out of scope")
}
lintCoercion (Refl ty)
= do { k <- lintType ty
; return (k, k, ty, ty, Nominal) }
= do { ty' <- lintType ty
; return (Refl ty') }
lintCoercion (GRefl r ty MRefl)
= do { k <- lintType ty