diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -16,14 +16,14 @@ import GhcPrelude import FastString -import Id -import Name -import NameEnv +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env import Outputable import PrimOp import SizedSeq -import Type -import SrcLoc +import GHC.Core.Type +import GHC.Types.SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.FFI diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -26,8 +26,8 @@ import GhcPrelude -import Id -import CostCentre +import GHC.Types.Id +import GHC.Types.CostCentre import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm.Node diff --git a/compiler/GHC/Cmm/BlockId.hs b/compiler/GHC/Cmm/BlockId.hs --- a/compiler/GHC/Cmm/BlockId.hs +++ b/compiler/GHC/Cmm/BlockId.hs @@ -11,10 +11,10 @@ import GhcPrelude import GHC.Cmm.CLabel -import IdInfo -import Name -import Unique -import UniqSupply +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) diff --git a/compiler/GHC/Cmm/BlockId.hs-boot b/compiler/GHC/Cmm/BlockId.hs-boot --- a/compiler/GHC/Cmm/BlockId.hs-boot +++ b/compiler/GHC/Cmm/BlockId.hs-boot @@ -1,7 +1,7 @@ module GHC.Cmm.BlockId (BlockId, mkBlockId) where import GHC.Cmm.Dataflow.Label (Label) -import Unique (Unique) +import GHC.Types.Unique (Unique) type BlockId = Label diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -115,20 +115,20 @@ import GhcPrelude -import IdInfo -import BasicTypes +import GHC.Types.Id.Info +import GHC.Types.Basic import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId) import GHC.Driver.Packages -import Module -import Name -import Unique +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Unique import PrimOp -import CostCentre +import GHC.Types.CostCentre import Outputable import FastString import GHC.Driver.Session import GHC.Platform -import UniqSet +import GHC.Types.Unique.Set import Util import GHC.Core.Ppr ( {- instances -} ) @@ -1029,7 +1029,7 @@ externalDynamicRefs && (this_pkg /= rtsUnitId) IdLabel n _ _ -> - isDllName dflags this_mod n + isDynLinkName dflags this_mod n -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library. @@ -1355,18 +1355,18 @@ internalNamePrefix :: Name -> SDoc internalNamePrefix name = getPprStyle $ \ sty -> if asmStyle sty && isRandomGenerated then - sdocWithPlatform $ \platform -> - ptext (asmTempLabelPrefix platform) + sdocWithDynFlags $ \dflags -> + ptext (asmTempLabelPrefix (targetPlatform dflags)) else empty where isRandomGenerated = not $ isExternalName name tempLabelPrefixOrUnderscore :: SDoc -tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform -> +tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags -> getPprStyle $ \ sty -> if asmStyle sty then - ptext (asmTempLabelPrefix platform) + ptext (asmTempLabelPrefix (targetPlatform dflags)) else char '_' diff --git a/compiler/GHC/Cmm/Dataflow/Block.hs b/compiler/GHC/Cmm/Dataflow/Block.hs --- a/compiler/GHC/Cmm/Dataflow/Block.hs +++ b/compiler/GHC/Cmm/Dataflow/Block.hs @@ -66,13 +66,7 @@ JustO :: t -> MaybeO O t NothingO :: MaybeO C t --- | Maybe type indexed by closed/open -data MaybeC ex t where - JustC :: t -> MaybeC C t - NothingC :: MaybeC O t - deriving instance Functor (MaybeO ex) -deriving instance Functor (MaybeC ex) -- ----------------------------------------------------------------------------- -- The Block type diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs --- a/compiler/GHC/Cmm/Dataflow/Label.hs +++ b/compiler/GHC/Cmm/Dataflow/Label.hs @@ -20,7 +20,7 @@ -- TODO: This should really just use GHC's Unique and Uniq{Set,FM} import GHC.Cmm.Dataflow.Collections -import Unique (Uniquable(..)) +import GHC.Types.Unique (Uniquable(..)) import TrieMap diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -32,18 +33,19 @@ import GhcPrelude +import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type import GHC.Driver.Session import Outputable (panic) -import Unique +import GHC.Types.Unique import Data.Set (Set) import qualified Data.Set as Set -import BasicTypes (Alignment, mkAlignment, alignmentOf) +import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) ----------------------------------------------------------------------------- -- CmmExpr @@ -209,37 +211,39 @@ -- of bytes used deriving Eq -cmmExprType :: DynFlags -> CmmExpr -> CmmType -cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit -cmmExprType _ (CmmLoad _ rep) = rep -cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg -cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) -cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg -cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address --- Careful though: what is stored at the stack slot may be bigger than --- an address +cmmExprType :: Platform -> CmmExpr -> CmmType +cmmExprType platform = \case + (CmmLit lit) -> cmmLitType platform lit + (CmmLoad _ rep) -> rep + (CmmReg reg) -> cmmRegType platform reg + (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args) + (CmmRegOff reg _) -> cmmRegType platform reg + (CmmStackSlot _ _) -> bWord platform -- an address + -- Careful though: what is stored at the stack slot may be bigger than + -- an address -cmmLitType :: DynFlags -> CmmLit -> CmmType -cmmLitType _ (CmmInt _ width) = cmmBits width -cmmLitType _ (CmmFloat _ width) = cmmFloat width -cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []" -cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l - in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls) - then cmmVec (1+length ls) ty - else panic "cmmLitType: CmmVec" -cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl -cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl -cmmLitType _ (CmmLabelDiffOff _ _ _ width) = cmmBits width -cmmLitType dflags (CmmBlock _) = bWord dflags -cmmLitType dflags (CmmHighStackMark) = bWord dflags +cmmLitType :: Platform -> CmmLit -> CmmType +cmmLitType platform = \case + (CmmInt _ width) -> cmmBits width + (CmmFloat _ width) -> cmmFloat width + (CmmVec []) -> panic "cmmLitType: CmmVec []" + (CmmVec (l:ls)) -> let ty = cmmLitType platform l + in if all (`cmmEqType` ty) (map (cmmLitType platform) ls) + then cmmVec (1+length ls) ty + else panic "cmmLitType: CmmVec" + (CmmLabel lbl) -> cmmLabelType platform lbl + (CmmLabelOff lbl _) -> cmmLabelType platform lbl + (CmmLabelDiffOff _ _ _ width) -> cmmBits width + (CmmBlock _) -> bWord platform + (CmmHighStackMark) -> bWord platform -cmmLabelType :: DynFlags -> CLabel -> CmmType -cmmLabelType dflags lbl - | isGcPtrLabel lbl = gcWord dflags - | otherwise = bWord dflags +cmmLabelType :: Platform -> CLabel -> CmmType +cmmLabelType platform lbl + | isGcPtrLabel lbl = gcWord platform + | otherwise = bWord platform -cmmExprWidth :: DynFlags -> CmmExpr -> Width -cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) +cmmExprWidth :: Platform -> CmmExpr -> Width +cmmExprWidth platform e = typeWidth (cmmExprType platform e) -- | Returns an alignment in bytes of a CmmExpr when it's a statically -- known integer constant, otherwise returns an alignment of 1 byte. @@ -278,12 +282,12 @@ instance Uniquable LocalReg where getUnique (LocalReg uniq _) = uniq -cmmRegType :: DynFlags -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg +cmmRegType :: Platform -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType platform (CmmGlobal reg) = globalRegType platform reg -cmmRegWidth :: DynFlags -> CmmReg -> Width -cmmRegWidth dflags = typeWidth . cmmRegType dflags +cmmRegWidth :: Platform -> CmmReg -> Width +cmmRegWidth platform = typeWidth . cmmRegType platform localRegType :: LocalReg -> CmmType localRegType (LocalReg _ rep) = rep @@ -590,23 +594,23 @@ node :: GlobalReg node = VanillaReg 1 VGcPtr -globalRegType :: DynFlags -> GlobalReg -> CmmType -globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags -globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags -globalRegType _ (FloatReg _) = cmmFloat W32 -globalRegType _ (DoubleReg _) = cmmFloat W64 -globalRegType _ (LongReg _) = cmmBits W64 --- TODO: improve the internal model of SIMD/vectorized registers --- the right design SHOULd improve handling of float and double code too. --- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim -globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32) -globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32) -globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) +globalRegType :: Platform -> GlobalReg -> CmmType +globalRegType platform = \case + (VanillaReg _ VGcPtr) -> gcWord platform + (VanillaReg _ VNonGcPtr) -> bWord platform + (FloatReg _) -> cmmFloat W32 + (DoubleReg _) -> cmmFloat W64 + (LongReg _) -> cmmBits W64 + -- TODO: improve the internal model of SIMD/vectorized registers + -- the right design SHOULd improve handling of float and double code too. + -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim + (XmmReg _) -> cmmVec 4 (cmmBits W32) + (YmmReg _) -> cmmVec 8 (cmmBits W32) + (ZmmReg _) -> cmmVec 16 (cmmBits W32) -globalRegType dflags Hp = gcWord dflags - -- The initialiser for all - -- dynamically allocated closures -globalRegType dflags _ = bWord dflags + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform isArgReg :: GlobalReg -> Bool isArgReg (VanillaReg {}) = True diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -30,9 +30,9 @@ import GhcPrelude +import GHC.Platform import GHC.Cmm.Type import Outputable -import GHC.Driver.Session ----------------------------------------------------------------------------- -- MachOp @@ -172,60 +172,60 @@ , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 - :: DynFlags -> MachOp + :: Platform -> MachOp mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 , mo_32To8, mo_32To16 :: MachOp -mo_wordAdd dflags = MO_Add (wordWidth dflags) -mo_wordSub dflags = MO_Sub (wordWidth dflags) -mo_wordEq dflags = MO_Eq (wordWidth dflags) -mo_wordNe dflags = MO_Ne (wordWidth dflags) -mo_wordMul dflags = MO_Mul (wordWidth dflags) -mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags) -mo_wordSRem dflags = MO_S_Rem (wordWidth dflags) -mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags) -mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags) -mo_wordURem dflags = MO_U_Rem (wordWidth dflags) +mo_wordAdd platform = MO_Add (wordWidth platform) +mo_wordSub platform = MO_Sub (wordWidth platform) +mo_wordEq platform = MO_Eq (wordWidth platform) +mo_wordNe platform = MO_Ne (wordWidth platform) +mo_wordMul platform = MO_Mul (wordWidth platform) +mo_wordSQuot platform = MO_S_Quot (wordWidth platform) +mo_wordSRem platform = MO_S_Rem (wordWidth platform) +mo_wordSNeg platform = MO_S_Neg (wordWidth platform) +mo_wordUQuot platform = MO_U_Quot (wordWidth platform) +mo_wordURem platform = MO_U_Rem (wordWidth platform) -mo_wordSGe dflags = MO_S_Ge (wordWidth dflags) -mo_wordSLe dflags = MO_S_Le (wordWidth dflags) -mo_wordSGt dflags = MO_S_Gt (wordWidth dflags) -mo_wordSLt dflags = MO_S_Lt (wordWidth dflags) +mo_wordSGe platform = MO_S_Ge (wordWidth platform) +mo_wordSLe platform = MO_S_Le (wordWidth platform) +mo_wordSGt platform = MO_S_Gt (wordWidth platform) +mo_wordSLt platform = MO_S_Lt (wordWidth platform) -mo_wordUGe dflags = MO_U_Ge (wordWidth dflags) -mo_wordULe dflags = MO_U_Le (wordWidth dflags) -mo_wordUGt dflags = MO_U_Gt (wordWidth dflags) -mo_wordULt dflags = MO_U_Lt (wordWidth dflags) +mo_wordUGe platform = MO_U_Ge (wordWidth platform) +mo_wordULe platform = MO_U_Le (wordWidth platform) +mo_wordUGt platform = MO_U_Gt (wordWidth platform) +mo_wordULt platform = MO_U_Lt (wordWidth platform) -mo_wordAnd dflags = MO_And (wordWidth dflags) -mo_wordOr dflags = MO_Or (wordWidth dflags) -mo_wordXor dflags = MO_Xor (wordWidth dflags) -mo_wordNot dflags = MO_Not (wordWidth dflags) -mo_wordShl dflags = MO_Shl (wordWidth dflags) -mo_wordSShr dflags = MO_S_Shr (wordWidth dflags) -mo_wordUShr dflags = MO_U_Shr (wordWidth dflags) +mo_wordAnd platform = MO_And (wordWidth platform) +mo_wordOr platform = MO_Or (wordWidth platform) +mo_wordXor platform = MO_Xor (wordWidth platform) +mo_wordNot platform = MO_Not (wordWidth platform) +mo_wordShl platform = MO_Shl (wordWidth platform) +mo_wordSShr platform = MO_S_Shr (wordWidth platform) +mo_wordUShr platform = MO_U_Shr (wordWidth platform) -mo_u_8To32 = MO_UU_Conv W8 W32 -mo_s_8To32 = MO_SS_Conv W8 W32 -mo_u_16To32 = MO_UU_Conv W16 W32 -mo_s_16To32 = MO_SS_Conv W16 W32 +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 -mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags) -mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags) -mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags) -mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags) -mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags) -mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags) +mo_u_8ToWord platform = MO_UU_Conv W8 (wordWidth platform) +mo_s_8ToWord platform = MO_SS_Conv W8 (wordWidth platform) +mo_u_16ToWord platform = MO_UU_Conv W16 (wordWidth platform) +mo_s_16ToWord platform = MO_SS_Conv W16 (wordWidth platform) +mo_s_32ToWord platform = MO_SS_Conv W32 (wordWidth platform) +mo_u_32ToWord platform = MO_UU_Conv W32 (wordWidth platform) -mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8 -mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16 -mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32 -mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64 +mo_WordTo8 platform = MO_UU_Conv (wordWidth platform) W8 +mo_WordTo16 platform = MO_UU_Conv (wordWidth platform) W16 +mo_WordTo32 platform = MO_UU_Conv (wordWidth platform) W32 +mo_WordTo64 platform = MO_UU_Conv (wordWidth platform) W64 -mo_32To8 = MO_UU_Conv W32 W8 -mo_32To16 = MO_UU_Conv W32 W16 +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 -- ---------------------------------------------------------------------------- @@ -365,8 +365,8 @@ {- | Returns the MachRep of the result of a MachOp. -} -machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType -machOpResultType dflags mop tys = +machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType +machOpResultType platform mop tys = case mop of MO_Add {} -> ty1 -- Preserve GC-ptr-hood MO_Sub {} -> ty1 -- of first arg @@ -379,29 +379,29 @@ MO_U_Quot r -> cmmBits r MO_U_Rem r -> cmmBits r - MO_Eq {} -> comparisonResultRep dflags - MO_Ne {} -> comparisonResultRep dflags - MO_S_Ge {} -> comparisonResultRep dflags - MO_S_Le {} -> comparisonResultRep dflags - MO_S_Gt {} -> comparisonResultRep dflags - MO_S_Lt {} -> comparisonResultRep dflags + MO_Eq {} -> comparisonResultRep platform + MO_Ne {} -> comparisonResultRep platform + MO_S_Ge {} -> comparisonResultRep platform + MO_S_Le {} -> comparisonResultRep platform + MO_S_Gt {} -> comparisonResultRep platform + MO_S_Lt {} -> comparisonResultRep platform - MO_U_Ge {} -> comparisonResultRep dflags - MO_U_Le {} -> comparisonResultRep dflags - MO_U_Gt {} -> comparisonResultRep dflags - MO_U_Lt {} -> comparisonResultRep dflags + MO_U_Ge {} -> comparisonResultRep platform + MO_U_Le {} -> comparisonResultRep platform + MO_U_Gt {} -> comparisonResultRep platform + MO_U_Lt {} -> comparisonResultRep platform MO_F_Add r -> cmmFloat r MO_F_Sub r -> cmmFloat r MO_F_Mul r -> cmmFloat r MO_F_Quot r -> cmmFloat r MO_F_Neg r -> cmmFloat r - MO_F_Eq {} -> comparisonResultRep dflags - MO_F_Ne {} -> comparisonResultRep dflags - MO_F_Ge {} -> comparisonResultRep dflags - MO_F_Le {} -> comparisonResultRep dflags - MO_F_Gt {} -> comparisonResultRep dflags - MO_F_Lt {} -> comparisonResultRep dflags + MO_F_Eq {} -> comparisonResultRep platform + MO_F_Ne {} -> comparisonResultRep platform + MO_F_Ge {} -> comparisonResultRep platform + MO_F_Le {} -> comparisonResultRep platform + MO_F_Gt {} -> comparisonResultRep platform + MO_F_Lt {} -> comparisonResultRep platform MO_And {} -> ty1 -- Used for pointer masking MO_Or {} -> ty1 @@ -445,7 +445,7 @@ where (ty1:_) = tys -comparisonResultRep :: DynFlags -> CmmType +comparisonResultRep :: Platform -> CmmType comparisonResultRep = bWord -- is it? @@ -457,8 +457,8 @@ -- its arguments are the same as the MachOp expects. This is used when -- linting a CmmExpr. -machOpArgReps :: DynFlags -> MachOp -> [Width] -machOpArgReps dflags op = +machOpArgReps :: Platform -> MachOp -> [Width] +machOpArgReps platform op = case op of MO_Add r -> [r,r] MO_Sub r -> [r,r] @@ -499,9 +499,9 @@ MO_Or r -> [r,r] MO_Xor r -> [r,r] MO_Not r -> [r] - MO_Shl r -> [r, wordWidth dflags] - MO_U_Shr r -> [r, wordWidth dflags] - MO_S_Shr r -> [r, wordWidth dflags] + MO_Shl r -> [r, wordWidth platform] + MO_U_Shr r -> [r, wordWidth platform] + MO_S_Shr r -> [r, wordWidth platform] MO_SS_Conv from _ -> [from] MO_UU_Conv from _ -> [from] @@ -510,8 +510,8 @@ MO_FS_Conv from _ -> [from] MO_FF_Conv from _ -> [from] - MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags] - MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth dflags] + MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform] + MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth platform] MO_V_Add _ r -> [r,r] MO_V_Sub _ r -> [r,r] @@ -524,8 +524,8 @@ MO_VU_Quot _ r -> [r,r] MO_VU_Rem _ r -> [r,r] - MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags] - MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags] + MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform] + MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth platform] MO_VF_Add _ r -> [r,r] MO_VF_Sub _ r -> [r,r] diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -33,11 +33,11 @@ import GHC.Cmm.Switch import GHC.Driver.Session import FastString -import ForeignCall +import GHC.Types.ForeignCall import Outputable import GHC.Runtime.Heap.Layout import GHC.Core (Tickish) -import qualified Unique as U +import qualified GHC.Types.Unique as U import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph @@ -45,7 +45,7 @@ import GHC.Cmm.Dataflow.Label import Data.Maybe import Data.List (tails,sortBy) -import Unique (nonDetCmpUnique) +import GHC.Types.Unique (nonDetCmpUnique) import Util diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -31,6 +31,7 @@ import GhcPrelude +import GHC.Platform import GHC.Driver.Session import FastString import Outputable @@ -120,14 +121,14 @@ f64 = cmmFloat W64 -- CmmTypes of native word widths -bWord :: DynFlags -> CmmType -bWord dflags = cmmBits (wordWidth dflags) +bWord :: Platform -> CmmType +bWord platform = cmmBits (wordWidth platform) -bHalfWord :: DynFlags -> CmmType -bHalfWord dflags = cmmBits (halfWordWidth dflags) +bHalfWord :: Platform -> CmmType +bHalfWord platform = cmmBits (halfWordWidth platform) -gcWord :: DynFlags -> CmmType -gcWord dflags = CmmType GcPtrCat (wordWidth dflags) +gcWord :: Platform -> CmmType +gcWord platform = CmmType GcPtrCat (wordWidth platform) cInt :: DynFlags -> CmmType cInt dflags = cmmBits (cIntWidth dflags) @@ -179,23 +180,20 @@ -------- Common Widths ------------ -wordWidth :: DynFlags -> Width -wordWidth dflags - | wORD_SIZE dflags == 4 = W32 - | wORD_SIZE dflags == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" +wordWidth :: Platform -> Width +wordWidth platform = case platformWordSize platform of + PW4 -> W32 + PW8 -> W64 -halfWordWidth :: DynFlags -> Width -halfWordWidth dflags - | wORD_SIZE dflags == 4 = W16 - | wORD_SIZE dflags == 8 = W32 - | otherwise = panic "MachOp.halfWordRep: Unknown word size" +halfWordWidth :: Platform -> Width +halfWordWidth platform = case platformWordSize platform of + PW4 -> W16 + PW8 -> W32 -halfWordMask :: DynFlags -> Integer -halfWordMask dflags - | wORD_SIZE dflags == 4 = 0xFFFF - | wORD_SIZE dflags == 8 = 0xFFFFFFFF - | otherwise = panic "MachOp.halfWordMask: Unknown word size" +halfWordMask :: Platform -> Integer +halfWordMask platform = case platformWordSize platform of + PW4 -> 0xFFFF + PW8 -> 0xFFFFFFFF -- cIntRep is the Width for a C-language 'int' cIntWidth :: DynFlags -> Width diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -89,7 +89,7 @@ -- * 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,24 +100,24 @@ #include "HsVersions.h" import GhcPrelude +import GHC.Platform -import CostCentre -import VarEnv( InScopeSet ) -import Var -import Type -import Coercion -import Name -import NameSet -import NameEnv( NameEnv, emptyNameEnv ) -import Literal -import DataCon -import Module -import BasicTypes -import GHC.Driver.Session +import GHC.Types.CostCentre +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env( NameEnv, emptyNameEnv ) +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Types.Module +import GHC.Types.Basic import Outputable import Util -import UniqSet -import SrcLoc ( RealSrcSpan, containsSpan ) +import GHC.Types.Unique.Set +import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import Binary import Data.Data hiding (TyCon) @@ -354,7 +354,7 @@ Also, we do not permit case analysis with literal patterns on floating-point types. See #9238 and Note [Rules for floating-point comparisons] in -PrelRules for the rationale for this restriction. +GHC.Core.Op.ConstantFold for the rationale for this restriction. -------------------------- GHC.Core INVARIANTS --------------------------- @@ -508,7 +508,7 @@ 5. Floating-point values must not be scrutinised against literals. See #9238 and Note [Rules for floating-point comparisons] - in PrelRules for rationale. Checked in lintCaseExpr; + in GHC.Core.Op.ConstantFold for rationale. Checked in lintCaseExpr; see the call to isFloatingTy. 6. The 'ty' field of (Case scrut bndr ty alts) is the type of the @@ -783,8 +783,8 @@ "" -> True _ -> False -The simplifier will pull the case into the join point (see Note [Case-of-case -and join points] in Simplify): +The simplifier will pull the case into the join point (see Note [Join points +and case-of-case] in GHC.Core.Op.Simplify): join j :: Int -> Bool -> Bool -- changed! @@ -879,7 +879,7 @@ ===> join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2 - n -> go @a (n-1) f (f x) + n -> go @a (n-1) f (f x) in go @Bool n neg True but that is ill-typed, as `x` is type `a`, not `Bool`. @@ -1276,7 +1276,7 @@ In contrast, orphans are all fingerprinted together in the mi_orph_hash field of the ModIface. - See GHC.Iface.Utils.addFingerprints. + See GHC.Iface.Recomp.addFingerprints. Orphan-hood is computed * For class instances: @@ -1284,8 +1284,8 @@ (because it is needed during instance lookup) * For rules and family instances: - when we generate an IfaceRule (GHC.Iface.Utils.coreRuleToIfaceRule) - or IfaceFamInst (GHC.Iface.Utils.instanceToIfaceInst) + when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule) + or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) -} {- @@ -1384,7 +1384,14 @@ } -- 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 @@ -1810,9 +1817,9 @@ -} -- The Ord is needed for the FiniteMap used in the lookForConstructor --- in SimplEnv. If you declared that lookForConstructor *ignores* --- constructor-applications with LitArg args, then you could get --- rid of this Ord. +-- in GHC.Core.Op.Simplify.Env. If you declared that lookForConstructor +-- *ignores* constructor-applications with LitArg args, then you could get rid +-- of this Ord. instance Outputable AltCon where ppr (DataAlt dc) = ppr dc @@ -1963,23 +1970,23 @@ -- | 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)) diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs --- a/compiler/GHC/Core/Arity.hs +++ b/compiler/GHC/Core/Arity.hs @@ -27,16 +27,16 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Subst -import Demand -import Var -import VarEnv -import Id -import Type -import TyCon ( initRecTc, checkRecTc ) -import Predicate ( isDictTy ) -import Coercion -import BasicTypes -import Unique +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Core.Type as Type +import GHC.Core.TyCon ( initRecTc, checkRecTc ) +import GHC.Core.Predicate ( isDictTy ) +import GHC.Core.Coercion as Coercion +import GHC.Types.Basic +import GHC.Types.Unique import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) import Outputable import FastString @@ -130,7 +130,7 @@ | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] - -- in TyCon + -- in GHC.Core.TyCon -- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes -- -- See Note [Newtype classes and eta expansion] -- (no longer required) diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Class.hs @@ -0,0 +1,360 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- The @Class@ datatype + +{-# LANGUAGE CPP #-} + +module GHC.Core.Class ( + Class, + ClassOpItem, + ClassATItem(..), + ClassMinimalDef, + DefMethInfo, pprDefMethInfo, + + FunDep, pprFundeps, pprFunDep, + + mkClass, mkAbstractClass, classTyVars, classArity, + classKey, className, classATs, classATItems, classTyCon, classMethods, + classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, + isAbstractClass, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Unique +import Util +import GHC.Types.SrcLoc +import Outputable +import BooleanFormula (BooleanFormula, mkTrue) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection[Class-basic]{@Class@: basic definition} +* * +************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: +-} + +data Class + = Class { + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep + + className :: Name, -- Just the cached name of the TyCon + classKey :: Unique, -- Cached unique of TyCon + + classTyVars :: [TyVar], -- The class kind and type variables; + -- identical to those of the TyCon + -- If you want visibility info, look at the classTyCon + -- This field is redundant because it's duplicated in the + -- classTyCon, but classTyVars is used quite often, so maybe + -- it's a bit faster to cache it here + + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + classBody :: ClassBody -- Superclasses, ATs, methods + + } + +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', + +-- For details on above see note [Api annotations] in ApiAnnotation +type FunDep a = ([a],[a]) + +type ClassOpItem = (Id, DefMethInfo) + -- Selector function; contains unfolding + -- Default-method info + +type DefMethInfo = Maybe (Name, DefMethSpec Type) + -- Nothing No default method + -- Just ($dm, VanillaDM) A polymorphic default method, name $dm + -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty + -- The generic dm type is *not* quantified + -- over the class variables; ie has the + -- class variables free + +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe (Type, SrcSpan)) + -- Default associated type (if any) from this template + -- Note [Associated type defaults] + +type ClassMinimalDef = BooleanFormula Name -- Required methods + +data ClassBody + = AbstractClass + | ConcreteClass { + -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses + cls_sc_theta :: [PredType], -- Immediate superclasses, + cls_sc_sel_ids :: [Id], -- Selector functions to extract the + -- superclasses from a + -- dictionary of this class + -- Associated types + cls_ats :: [ClassATItem], -- Associated type families + + -- Class operations (methods, not superclasses) + cls_ops :: [ClassOpItem], -- Ordered by tag + + -- Minimal complete definition + cls_min_def :: ClassMinimalDef + } + -- TODO: maybe super classes should be allowed in abstract class definitions + +classMinimalDef :: Class -> ClassMinimalDef +classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d +classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction + +{- +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + +The @mkClass@ function fills in the indirect superclasses. + +The SrcSpan is for the entire original declaration. +-} + +mkClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> [PredType] -> [Id] + -> [ClassATItem] + -> [ClassOpItem] + -> ClassMinimalDef + -> TyCon + -> Class + +mkClass cls_name tyvars fds super_classes superdict_sels at_stuff + op_stuff mindef tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = ConcreteClass { + cls_sc_theta = super_classes, + cls_sc_sel_ids = superdict_sels, + cls_ats = at_stuff, + cls_ops = op_stuff, + cls_min_def = mindef + }, + classTyCon = tycon } + +mkAbstractClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> TyCon + -> Class + +mkAbstractClass cls_name tyvars fds tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = AbstractClass, + classTyCon = tycon } + +{- +Note [Associated type tyvar names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCon of an associated type should use the same variable names as its +parent class. Thus + class C a b where + type F b x a :: * +We make F use the same Name for 'a' as C does, and similarly 'b'. + +The reason for this is when checking instances it's easier to match +them up, to ensure they match. Eg + instance C Int [d] where + type F [d] x Int = .... +we should make sure that the first and third args match the instance +header. + +Having the same variables for class and tycon is also used in checkValidRoles +(in TcTyClsDecls) when checking a class's roles. + + +************************************************************************ +* * +\subsection[Class-selectors]{@Class@: simple selectors} +* * +************************************************************************ + +The rest of these functions are just simple selectors. +-} + +classArity :: Class -> Arity +classArity clas = length (classTyVars clas) + -- Could memoise this + +classAllSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels ++ classMethods c +classAllSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels +classSCSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelId :: Class -> Int -> Id +-- Get the n'th superclass selector Id +-- where n is 0-indexed, and counts +-- *all* superclasses including equalities +classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n + = ASSERT( n >= 0 && lengthExceeds sc_sels n ) + sc_sels !! n +classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) + +classMethods :: Class -> [Id] +classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) + = [op_sel | (op_sel, _) <- op_stuff] +classMethods _ = [] + +classOpItems :: Class -> [ClassOpItem] +classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) + = op_stuff +classOpItems _ = [] + +classATs :: Class -> [TyCon] +classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) + = [tc | ATI tc _ <- at_stuff] +classATs _ = [] + +classATItems :: Class -> [ClassATItem] +classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) + = at_stuff +classATItems _ = [] + +classSCTheta :: Class -> [PredType] +classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) + = theta_stuff +classSCTheta _ = [] + +classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) +classTvsFds c = (classTyVars c, classFunDeps c) + +classHasFds :: Class -> Bool +classHasFds (Class { classFunDeps = fds }) = not (null fds) + +classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) +classBigSig (Class {classTyVars = tyvars, + classBody = AbstractClass}) + = (tyvars, [], [], []) +classBigSig (Class {classTyVars = tyvars, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, + cls_sc_sel_ids = sc_sels, + cls_ops = op_stuff + }}) + = (tyvars, sc_theta, sc_sels, op_stuff) + +classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = AbstractClass}) + = (tyvars, fundeps, [], [], [], []) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, + cls_ats = ats, cls_ops = op_stuff + }}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) + +isAbstractClass :: Class -> Bool +isAbstractClass Class{ classBody = AbstractClass } = True +isAbstractClass _ = False + +{- +************************************************************************ +* * +\subsection[Class-instances]{Instance declarations for @Class@} +* * +************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). +-} + +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Uniquable Class where + getUnique c = classKey c + +instance NamedThing Class where + getName clas = className clas + +instance Outputable Class where + ppr c = ppr (getName c) + +pprDefMethInfo :: DefMethInfo -> SDoc +pprDefMethInfo Nothing = empty -- No default method +pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n +pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" + <+> ppr n <+> dcolon <+> pprType ty + +pprFundeps :: Outputable a => [FunDep a] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: Outputable a => FunDep a -> SDoc +pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Coercion.hs @@ -0,0 +1,2947 @@ +{- +(c) The University of Glasgow 2006 +-} + +{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, + ScopedTypeVariables #-} + +-- | Module for (a) type kinds and (b) type coercions, +-- as used in System FC. See 'GHC.Core.Expr' for +-- more on System FC and how coercions fit into it. +-- +module GHC.Core.Coercion ( + -- * Main data type + Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, + UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..), + coHoleCoVar, setCoHoleCoVar, + LeftOrRight(..), + Var, CoVar, TyCoVar, + Role(..), ltRole, + + -- ** Functions over coercions + coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, + coercionType, mkCoercionType, + coercionKind, coercionLKind, coercionRKind,coercionKinds, + coercionRole, coercionKindRole, + + -- ** Constructing coercions + mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, mkTransMCo, + mkNthCo, nthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, + mkForAllCo, mkForAllCos, mkHomoForAllCos, + mkPhantomCo, + mkHoleCo, mkUnivCo, mkSubCo, + mkAxiomInstCo, mkProofIrrelCo, + downgradeRole, mkAxiomRuleCo, + mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, + mkKindCo, castCoercionKind, castCoercionKindI, + + mkHeteroCoercionType, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, + mapStepResult, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX, + + decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, + splitTyConAppCo_maybe, + splitAppCo_maybe, + splitFunCo_maybe, + splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + + nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + + pickLR, + + isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, + isReflCoVar_maybe, isGReflMCo, coToMCo, + + -- ** Coercion variables + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + isCoVar_maybe, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, + coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTvSubstAndInScope, getCvSubstEnv, + + -- ** Lifting + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, + liftCoSubstVarBndrUsing, isMappedByLC, + + mkSubstLiftingContext, zapLiftingContext, + substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, + + -- ** Comparison + eqCoercion, eqCoercionX, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, + pprCoAxBranchUser, tidyCoAxBndrsForUser, + etaExpandCoAxBranch, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + promoteCoercion, buildCoercion, + + simplifyArgsWorker, + + badCoercionHole, badCoercionHoleCo + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) + +import GhcPrelude + +import GHC.Iface.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) +import Util +import GHC.Types.Basic +import Outputable +import GHC.Types.Unique +import Pair +import GHC.Types.SrcLoc +import PrelNames +import TysPrim +import ListSetOps +import Maybes +import GHC.Types.Unique.FM + +import Control.Monad (foldM, zipWithM) +import Data.Function ( on ) +import Data.Char( isDigit ) +import qualified Data.Monoid as Monoid + +{- +%************************************************************************ +%* * + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep + +\subsection{Coercion variables} +%* * +%************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +{- +%************************************************************************ +%* * + Pretty-printing CoAxioms +%* * +%************************************************************************ + +Defined here to avoid module loops. CoAxiom is loaded very early on. + +-} + +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + +pprCoAxiom :: CoAxiom br -> SDoc +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (text "axiom" <+> ppr ax <+> dcolon) + 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.reportInjectivityErrors) +-- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (#14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs + where + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs + +ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) + -> TyCon -> CoAxBranch -> SDoc +ppr_co_ax_branch ppr_rhs fam_tc branch + = foldr1 (flip hangNotEmpty 2) + [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + , pp_lhs <+> ppr_rhs tidy_env ee_rhs + , text "-- Defined" <+> pp_loc ] + where + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs + +tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +tidyCoAxBndrsForUser init_env tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs + + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOcc "_") + -- Tidy the binder to "_" + + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False + +{- +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ + +Note [Function coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Remember that + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep + +Hence + FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) +is short for + TyConAppCo (->) co_rep1 co_rep2 co1 co2 +where co_rep1, co_rep2 are the coercions on the representations. +-} + + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] +decomposeCo :: Arity -> Coercion + -> [Role] -- the roles of the output coercions + -- this must have at least as many + -- entries as the Arity provided + -> [Coercion] +decomposeCo arity co rs + = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] + -- Remember, Nth is zero-indexed + +decomposeFunCo :: HasDebugCallStack + => Role -- Role of the input coercion + -> Coercion -- Input coercion + -> (Coercion, Coercion) +-- Expects co :: (s1 -> t1) ~ (s2 -> t2) +-- Returns (co1 :: s1~s2, co2 :: t1~t2) +-- See Note [Function coercions] for the "2" and "3" +decomposeFunCo r co = ASSERT2( all_ok, ppr co ) + (mkNthCo r 2 co, mkNthCo r 3 co) + where + Pair s1t1 s2t2 = coercionKind co + all_ok = isFunTy s1t1 && isFunTy s2t2 + +{- Note [Pushing a coercion into a pi-type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this: + (f |> co) t1 .. tn +Then we want to push the coercion into the arguments, so as to make +progress. For example of why you might want to do so, see Note +[Respecting definitional equality] in GHC.Core.TyCo.Rep. + +This is done by decomposePiCos. Specifically, if + decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) +then + (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn + +Notes: + +* k can be smaller than n! That is decomposePiCos can return *fewer* + coercions than there are arguments (ie k < n), if the kind provided + doesn't have enough binders. + +* If there is a type error, we might see + (f |> co) t1 + where co :: (forall a. ty) ~ (ty1 -> ty2) + Here 'co' is insoluble, but we don't want to crash in decoposePiCos. + So decomposePiCos carefully tests both sides of the coercion to check + they are both foralls or both arrows. Not doing this caused #15343. +-} + +decomposePiCos :: HasDebugCallStack + => CoercionN -> Pair Type -- Coercion and its kind + -> [Type] + -> ([CoercionN], CoercionN) +-- See Note [Pushing a coercion into a pi-type] +decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args + = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args + where + orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co + + go :: [CoercionN] -- accumulator for argument coercions, reversed + -> (TCvSubst,Kind) -- Lhs kind of coercion + -> CoercionN -- coercion originally applied to the function + -> (TCvSubst,Kind) -- Rhs kind of coercion + -> [Type] -- Arguments to that function + -> ([CoercionN], Coercion) + -- Invariant: co :: subst1(k2) ~ subst2(k2) + + go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) + | Just (a, t1) <- splitForAllTy_maybe k1 + , Just (b, t2) <- splitForAllTy_maybe k2 + -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) + -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) + -- a :: s1 + -- b :: s2 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] + = let arg_co = mkNthCo Nominal 0 (mkSymCo co) + res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) + subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) + subst2' = extendTCvSubst subst2 b ty + in + go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys + + | Just (_s1, t1) <- splitFunTy_maybe k1 + , Just (_s2, t2) <- splitFunTy_maybe k2 + -- know co :: (s1 -> t1) ~ (s2 -> t2) + -- function :: s1 -> t1 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1 ~ t2 + = let (sym_arg_co, res_co) = decomposeFunCo Nominal co + arg_co = mkSymCo sym_arg_co + in + go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys + + | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) + = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) + co + (zapTCvSubst subst2, substTy subst1 k2) + (ty:tys) + + -- tys might not be empty, if the left-hand type of the original coercion + -- didn't have enough binders + go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) + +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + = do { (tc, tys) <- splitTyConApp_maybe ty + ; let args = zipWith mkReflCo (tyConRolesX r tc) tys + ; return (tc, args) } +splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) +splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) + where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] +splitTyConAppCo_maybe _ = Nothing + +-- first result has role equal to input; third result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | args `lengthExceeds` tyConArity tc + , Just (args', arg') <- snocView args + = Just ( mkTyConAppCo r tc args', arg' ) + + | not (mustBeSaturated tc) + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' + = Just ( mkTyConAppCo r tc args', arg'' ) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl + +splitAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (mkReflCo r ty1, mkNomReflCo ty2) +splitAppCo_maybe _ = Nothing + +splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) +splitFunCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) +splitForAllCo_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_ty_maybe (ForAllCo tv k_co co) + | isTyVar tv = Just (tv, k_co, co) +splitForAllCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +splitForAllCo_co_maybe (ForAllCo cv k_co co) + | isCoVar cv = Just (cv, k_co, co) +splitForAllCo_co_maybe _ = Nothing + +------------------------------------------------------- +-- and some coercion kind stuff + +coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type +coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1 +coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2 + +coVarTypes :: HasDebugCallStack => CoVar -> Pair Type +coVarTypes cv + | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv + = Pair ty1 ty2 + +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) +coVarKindsTypesRole cv + | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = (k1, k2, ty1, ty2, eqTyConRole tc) + | otherwise + = pprPanic "coVarKindsTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type +coVarKind cv + = ASSERT( isCoVar cv ) + varType cv + +coVarRole :: CoVar -> Role +coVarRole cv + = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) + +eqTyConRole :: TyCon -> Role +-- Given (~#) or (~R#) return the Nominal or Representational respectively +eqTyConRole tc + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "eqTyConRole: unknown tycon" (ppr tc) + +-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, +-- produce a coercion @rep_co :: r1 ~ r2@. +mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion +mkRuntimeRepCo co + = mkNthCo Nominal 0 kind_co + where + kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 + -- (up to silliness with Constraint) + +isReflCoVar_maybe :: Var -> Maybe Coercion +-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) +-- Works on all kinds of Vars, not just CoVars +isReflCoVar_maybe cv + | isCoVar cv + , Pair ty1 ty2 <- coVarTypes cv + , ty1 `eqType` ty2 + = Just (mkReflCo (coVarRole cv) ty1) + | otherwise + = Nothing + +-- | Tests if this coercion is obviously a generalized reflexive coercion. +-- Guaranteed to work very quickly. +isGReflCo :: Coercion -> Bool +isGReflCo (GRefl{}) = True +isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo _ = False + +-- | Tests if this MCoercion is obviously generalized reflexive +-- Guaranteed to work very quickly. +isGReflMCo :: MCoercion -> Bool +isGReflMCo MRefl = True +isGReflMCo (MCo co) | isGReflCo co = True +isGReflMCo _ = False + +-- | Tests if this coercion is obviously reflexive. Guaranteed to work +-- very quickly. Sometimes a coercion can be reflexive, but not obviously +-- so. c.f. 'isReflexiveCo' +isReflCo :: Coercion -> Bool +isReflCo (Refl{}) = True +isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo _ = False + +-- | Returns the type coerced if this coercion is a generalized reflexive +-- coercion. Guaranteed to work very quickly. +isGReflCo_maybe :: Coercion -> Maybe (Type, Role) +isGReflCo_maybe (GRefl r ty _) = Just (ty, r) +isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe _ = Nothing + +-- | Returns the type coerced if this coercion is reflexive. Guaranteed +-- to work very quickly. Sometimes a coercion can be reflexive, but not +-- obviously so. c.f. 'isReflexiveCo_maybe' +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl ty) = Just (ty, Nominal) +isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe _ = Nothing + +-- | Slowly checks if the coercion is reflexive. Don't call this in a loop, +-- as it walks over the entire coercion. +isReflexiveCo :: Coercion -> Bool +isReflexiveCo = isJust . isReflexiveCo_maybe + +-- | Extracts the coerced type from a reflexive coercion. This potentially +-- walks over the entire coercion, so avoid doing this in a loop. +isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) +isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) +isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflexiveCo_maybe co + | ty1 `eqType` ty2 + = Just (ty1, r) + | otherwise + = Nothing + where (Pair ty1 ty2, r) = coercionKindRole co + +coToMCo :: Coercion -> MCoercion +coToMCo c = if isReflCo c + then MRefl + else MCo c + +{- +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. (Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. + +-} + +-- | Make a generalized reflexive coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflCo r ty mco + | isGReflMCo mco = if r == Nominal then Refl ty + else GRefl r ty MRefl + | otherwise = GRefl r ty mco + +-- | Make a reflexive coercion +mkReflCo :: Role -> Type -> Coercion +mkReflCo Nominal ty = Refl ty +mkReflCo r ty = GRefl r ty MRefl + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo ty = GRefl Representational ty MRefl + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = Refl + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + | tc `hasKey` funTyConKey + , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] + = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) + -- rep1 :: ra ~ rc rep2 :: rb ~ rd + -- co1 :: a ~ c co2 :: b ~ d + mkFunCo r co1 co2 + + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos + + | Just tys_roles <- traverse isReflCo_maybe cos + = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +-- | Build a function 'Coercion' from two other 'Coercion's. That is, +-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkFunCo r co1 co2 + -- See Note [Refl invariant] + | Just (ty1, _) <- isReflCo_maybe co1 + , Just (ty2, _) <- isReflCo_maybe co2 + = mkReflCo r (mkVisFunTy ty1 ty2) + | otherwise = FunCo r co1 co2 + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo co arg + | Just (ty1, r) <- isReflCo_maybe co + , Just (ty2, _) <- isReflCo_maybe arg + = mkReflCo r (mkAppTy ty1 ty2) + + | Just (ty1, r) <- isReflCo_maybe co + , Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) + = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) + Representational -> mkTyConAppCo Representational tc (args ++ [arg']) + where new_role = (tyConRolesRepresentational tc) !! (length args) + arg' = downgradeRole new_role Nominal arg + Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl' mkAppCo co1 cos + +{- Note [Unused coercion variable in ForAllCo] + +See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the +motivation for checking coercion variable in types. +To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: + +(1) In mkForAllCo, we check whether cv is a coercion variable + and whether it is not used in body_co. If so we construct a FunCo. +(2) We don't do this check in mkForAllCo. + In coercionKind, we use mkTyCoForAllTy to perform the check and construct + a FunTy when necessary. + +We chose (2) for two reasons: + +* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not + make a difference. +* even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. + +The last wrinkle is that there are restrictions around the use of the cv in the +coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that +we cannot prove that the type system is consistent with unrestricted use of this +cv; the consistency proof uses an untyped rewrite relation that works over types +with all coercions and casts removed. So, we can allow the cv to appear only in +positions that are erased. As an approximation of this (and keeping close to the +published theory), we currently allow the cv only within the type in a Refl node +and under a GRefl node (including in the Coercion stored in a GRefl). It's +possible other places are OK, too, but this is a safe approximation. + +Sadly, with heterogeneous equality, this restriction might be able to be violated; +Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst +function might create an invalid coercion. Because a violation of the +restriction might lead to a program that "goes wrong", it is checked all the time, +even in a production compiler and without -dcore-list. We *have* proved that the +problem does not occur with homogeneous equality, so this check can be dropped +once ~# is made to be homogeneous. +-} + + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +-- See Note [Unused coercion variable in ForAllCo] +mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , Just (ty, r) <- isReflCo_maybe co + , isGReflCo kind_co + = mkReflCo r (mkTyCoInvForAllTy v ty) + | otherwise + = ForAllCo v kind_co co + +-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , ASSERT( not (isReflCo co)) True + , isCoVar v + , not (v `elemVarSet` tyCoVarsOfCo co) + = FunCo (coercionRole co) kind_co co + | otherwise + = ForAllCo v kind_co co + +-- | Make nested ForAllCos +mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion +mkForAllCos bndrs co + | Just (ty, r ) <- isReflCo_maybe co + = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in + foldl' (flip $ uncurry mkForAllCo_NoRefl) + (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) + non_refls_rev'd + | otherwise + = foldr (uncurry mkForAllCo_NoRefl) co bndrs + +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos vs co + | Just (ty, r) <- isReflCo_maybe co + = mkReflCo r (mkTyCoInvForAllTys vs ty) + | otherwise + = mkHomoForAllCos_NoRefl vs co + +-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. +mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl vs orig_co + = ASSERT( not (isReflCo orig_co)) + foldr go orig_co vs + where + go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +-- See Note [mkCoVarCo] +mkCoVarCo cv = CoVarCo cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +{- Note [mkCoVarCo] +~~~~~~~~~~~~~~~~~~~ +In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is +valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but +it's a relatively expensive test and perhaps better done in +optCoercion. Not a big deal either way. +-} + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +isCoVar_maybe :: Coercion -> Maybe CoVar +isCoVar_maybe (CoVarCo cv) = Just cv +isCoVar_maybe _ = Nothing + +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] + -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires +mkAxInstCo role ax index tys cos + | arity == n_tys = downgradeRole role ax_role $ + mkAxiomInstCo ax_br index (rtys `chkAppend` cos) + | otherwise = ASSERT( arity < n_tys ) + downgradeRole role ax_role $ + mkAppCos (mkAxiomInstCo ax_br index + (ax_args `chkAppend` cos)) + leftover_args + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + tvs = coAxBranchTyVars branch + arity = length tvs + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) + = splitAt arity rtys + ax_role = coAxiomRole ax + +-- worker function +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkAxiomInstCo ax index args + = ASSERT( args `lengthIs` coAxiomArity ax index ) + AxiomInstCo ax index args + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched + -> [Type] -> [Coercion] -> Coercion +mkUnbranchedAxInstCo role ax tys cos + = mkAxInstCo role ax 0 tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Coercion +mkHoleCo h = HoleCo h + +-- | Make a universal coercion between two arbitrary types. +mkUnivCo :: UnivCoProvenance + -> Role -- ^ role of the built coercion, "r" + -> Type -- ^ t1 :: k1 + -> Type -- ^ t2 :: k2 + -> Coercion -- ^ :: t1 ~r t2 +mkUnivCo prov role ty1 ty2 + | ty1 `eqType` ty2 = mkReflCo role ty1 + | otherwise = UnivCo prov role ty1 ty2 + +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co | isReflCo co = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +-- (co1 ; co2) +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo co1 co2 | isReflCo co1 = co2 + | isReflCo co2 = co1 +mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) + = GRefl r t1 (MCo $ mkTransCo co1 co2) +mkTransCo co1 co2 = TransCo co1 co2 + +-- | Compose two MCoercions via transitivity +mkTransMCo :: MCoercion -> MCoercion -> MCoercion +mkTransMCo MRefl co2 = co2 +mkTransMCo co1 MRefl = co1 +mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) + +mkNthCo :: HasDebugCallStack + => Role -- The role of the coercion you're creating + -> Int -- Zero-indexed + -> Coercion + -> Coercion +mkNthCo r n co + = ASSERT2( good_call, bad_call_msg ) + go r n co + where + Pair ty1 ty2 = coercionKind co + + go r 0 co + | Just (ty, _) <- isReflCo_maybe co + , Just (tv, _) <- splitForAllTy_maybe ty + = -- works for both tyvar and covar + ASSERT( r == Nominal ) + mkNomReflCo (varType tv) + + go r n co + | Just (ty, r0) <- isReflCo_maybe co + , let tc = tyConAppTyCon ty + = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) + ASSERT( nthRole r0 tc n == r ) + mkReflCo r (tyConAppArgN n ty) + where ok_tc_app :: Type -> Int -> Bool + ok_tc_app ty n + | Just (_, tys) <- splitTyConApp_maybe ty + = tys `lengthExceeds` n + | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall + = n == 0 + | otherwise + = False + + go r 0 (ForAllCo _ kind_co _) + = ASSERT( r == Nominal ) + kind_co + -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) + -- then (nth 0 co :: k1 ~N k2) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) + + go r n co@(FunCo r0 arg res) + -- See Note [Function coercions] + -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) + -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) + -- Then we want to behave as if co was + -- TyConAppCo argk_co resk_co arg_co res_co + -- where + -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) + -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) + -- i.e. mkRuntimeRepCo + = case n of + 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg + 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res + 2 -> ASSERT( r == r0 ) arg + 3 -> ASSERT( r == r0 ) res + _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) + + go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n + , (vcat [ ppr tc + , ppr arg_cos + , ppr r0 + , ppr n + , ppr r ]) ) + arg_cos `getNth` n + + go r n co = + NthCo r n co + + -- Assertion checking + bad_call_msg = vcat [ text "Coercion =" <+> ppr co + , text "LHS ty =" <+> ppr ty1 + , text "RHS ty =" <+> ppr ty2 + , text "n =" <+> ppr n, text "r =" <+> ppr r + , text "coercion role =" <+> ppr (coercionRole co) ] + good_call + -- If the Coercion passed in is between forall-types, then the Int must + -- be 0 and the role must be Nominal. + | Just (_tv1, _) <- splitForAllTy_maybe ty1 + , Just (_tv2, _) <- splitForAllTy_maybe ty2 + = n == 0 && r == Nominal + + -- If the Coercion passed in is between T tys and T tys', then the Int + -- must be less than the length of tys/tys' (which must be the same + -- lengths). + -- + -- If the role of the Coercion is nominal, then the role passed in must + -- be nominal. If the role of the Coercion is representational, then the + -- role passed in must be tyConRolesRepresentational T !! n. If the role + -- of the Coercion is Phantom, then the role passed in must be Phantom. + -- + -- See also Note [NthCo Cached Roles] if you're wondering why it's + -- blaringly obvious that we should be *computing* this role instead of + -- passing it in. + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + = let len1 = length tys1 + len2 = length tys2 + good_role = case coercionRole co of + Nominal -> r == Nominal + Representational -> r == (tyConRolesRepresentational tc1 !! n) + Phantom -> r == Phantom + in len1 == len2 && n < len1 && good_role + + | otherwise + = True + + + +-- | If you're about to call @mkNthCo r n co@, then @r@ should be +-- whatever @nthCoRole n co@ returns. +nthCoRole :: Int -> Coercion -> Role +nthCoRole n co + | Just (tc, _) <- splitTyConApp_maybe lty + = nthRole r tc n + + | Just _ <- splitForAllTy_maybe lty + = Nominal + + | otherwise + = pprPanic "nthCoRole" (ppr co) + + where + lty = coercionLKind co + r = coercionRole co + +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr co + | Just (ty, eq) <- isReflCo_maybe co + = mkReflCo eq (pickLR lr (splitAppTy ty)) + | otherwise + = LRCo lr co + +-- | Instantiates a 'Coercion'. +mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo (ForAllCo tcv _kind_co body_co) co + | Just (arg, _) <- isReflCo_maybe co + -- works for both tyvar and covar + = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co +mkInstCo co arg = InstCo co arg + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion +mkGReflRightCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion +mkGReflLeftCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkSymCo $ GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceLeftCo r ty co co2 + | isGReflCo co = co2 + | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, +-- produces @co' :: ty' ~r (ty |> co) +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo r ty co co2 + | isGReflCo co = co2 + | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) + +-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. +mkKindCo :: Coercion -> Coercion +mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) +mkKindCo (GRefl _ _ (MCo co)) = co +mkKindCo (UnivCo (PhantomProv h) _ _ _) = h +mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h +mkKindCo co + | Pair ty1 ty2 <- coercionKind co + -- generally, calling coercionKind during coercion creation is a bad idea, + -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, + -- so it's OK here. + , let tk1 = typeKind ty1 + tk2 = typeKind ty2 + , tk1 `eqType` tk2 + = Refl tk1 + | otherwise + = KindCo co + +mkSubCo :: Coercion -> Coercion +-- Input coercion is Nominal, result is Representational +-- see also Note [Role twiddling functions] +mkSubCo (Refl ty) = GRefl Representational ty MRefl +mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo (FunCo Nominal arg res) + = FunCo Representational + (downgradeRole Representational Nominal arg) + (downgradeRole Representational Nominal res) +mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) + SubCo co + +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion +-- In (downgradeRole_maybe dr cr co) it's a precondition that +-- cr = coercionRole co + +downgradeRole_maybe Nominal Nominal co = Just co +downgradeRole_maybe Nominal _ _ = Nothing + +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Representational Representational co = Just co +downgradeRole_maybe Representational Phantom _ = Nothing + +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) + +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomRuleCo = AxiomRuleCo + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> Coercion -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) + -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ +mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r + (mkCoercionTy g1) (mkCoercionTy g2) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] +setNominalRole_maybe :: Role -- of input coercion + -> Coercion -> Maybe Coercion +setNominalRole_maybe r co + | r == Nominal = Just co + | otherwise = setNominalRole_maybe_helper co + where + setNominalRole_maybe_helper (SubCo co) = Just co + setNominalRole_maybe_helper co@(Refl _) = Just co + setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co + setNominalRole_maybe_helper (TyConAppCo Representational tc cos) + = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos + ; return $ TyConAppCo Nominal tc cos' } + setNominalRole_maybe_helper (FunCo Representational co1 co2) + = do { co1' <- setNominalRole_maybe Representational co1 + ; co2' <- setNominalRole_maybe Representational co2 + ; return $ FunCo Nominal co1' co2' + } + setNominalRole_maybe_helper (SymCo co) + = SymCo <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 + setNominalRole_maybe_helper (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 + setNominalRole_maybe_helper (ForAllCo tv kind_co co) + = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (NthCo _r n co) + -- NB, this case recurses via setNominalRole_maybe, not + -- setNominalRole_maybe_helper! + = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co + setNominalRole_maybe_helper (InstCo co arg) + = InstCo <$> setNominalRole_maybe_helper co <*> pure arg + setNominalRole_maybe_helper (UnivCo prov _ co1 co2) + | case prov of PhantomProv _ -> False -- should always be phantom + ProofIrrelProv _ -> True -- it's always safe + PluginProv _ -> False -- who knows? This choice is conservative. + = Just $ UnivCo prov Nominal co1 co2 + setNominalRole_maybe_helper _ = Nothing + +-- | Make a phantom coercion between two types. The coercion passed +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo (PhantomProv h) Phantom t1 t2 + +-- takes any coercion and turns it into a Phantom coercion +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles tc cos + = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos + +-- the Role parameter is the Role of the TyConAppCo +-- defined here because this is intimately concerned with the implementation +-- of TyConAppCo +-- Always returns an infinite list (with a infinite tail of Nominal) +tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX Representational tc = tyConRolesRepresentational tc +tyConRolesX role _ = repeat role + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRolesRepresentational :: TyCon -> [Role] +tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal + +nthRole :: Role -> TyCon -> Int -> Role +nthRole Nominal _ _ = Nominal +nthRole Phantom _ _ = Phantom +nthRole Representational tc n + = (tyConRolesRepresentational tc) `getNth` n + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: Coercion -> CoercionN + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- no later branch should return refl + -- The ASSERT( False )s throughout + -- are these cases explicitly, but they should never fire. + + Refl _ -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ MRefl -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ (MCo co) -> co + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo tv _ g + | isTyVar tv + -> promoteCoercion g + + ForAllCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep + + FunCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + CoVarCo {} -> mkKindCo co + HoleCo {} -> mkKindCo co + AxiomInstCo {} -> mkKindCo co + AxiomRuleCo {} -> mkKindCo co + + UnivCo (PhantomProv kco) _ _ _ -> kco + UnivCo (ProofIrrelProv kco) _ _ _ -> kco + UnivCo (PluginProv _) _ _ _ -> mkKindCo co + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + NthCo _ n co1 + | Just (_, args) <- splitTyConAppCo_maybe co1 + , args `lengthExceeds` n + -> promoteCoercion (args !! n) + + | Just _ <- splitForAllCo_maybe co + , n == 0 + -> ASSERT( False ) mkNomReflCo liftedTypeKind + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + | isForAllTy_ty ty1 + -> ASSERT( isForAllTy_ty ty2 ) + promoteCoercion g + | otherwise + -> ASSERT( False) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep + + KindCo _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal + -> Coercion + -> Maybe CoercionN +instCoercion (Pair lty rty) g w + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) + , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] + = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 + = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) + | otherwise -- one forall, one funty... + = Nothing + +-- | Repeated use of 'instCoercion' +instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) +-- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand. +castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion +castCoercionKindI g h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + where (Pair t1 t2, r) = coercionKindRole g + +-- See note [Newtype coercions] in GHC.Core.TyCon + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +-- | Make a forall 'Coercion', where both types related by the coercion +-- are quantified over the same variable. +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co + | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) + -- We didn't call mkForAllCo here because if v does not appear + -- in co, the argement coercion will be nominal. But here we + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in GHC.Core.Op.Simplify.Utils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunCo r (mkReflCo r (varType v)) co + | otherwise = mkFunCo r (mkReflCo r (varType v)) co + +-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 +-- The first coercion might be lifted or unlifted; thus the ~? above +-- Lifted and unlifted equalities take different numbers of arguments, +-- so we have to make sure to supply the right parameter to decomposeCo. +-- Also, note that the role of the first coercion is the same as the role of +-- the equalities related by the second coercion. The second coercion is +-- itself always representational. +mkCoCast :: Coercion -> CoercionR -> Coercion +mkCoCast c g + | (g2:g1:_) <- reverse co_list + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + + | otherwise + = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) + where + -- g :: (s1 ~# t1) ~# (s2 ~# t2) + -- g1 :: s1 ~# s2 + -- g2 :: t1 ~# t2 + (tc, _) = splitTyConApp (coercionLKind g) + co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) + +{- +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX'. +type NormaliseStepper ev = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult ev + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX'. +data NormaliseStepResult ev + = NS_Done -- ^ Nothing more to do + | NS_Abort -- ^ Utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; + -- ^ ev is evidence; + -- Usually a co :: old type ~ new type + +mapStepResult :: (ev1 -> ev2) + -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 +mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) +mapStepResult _ NS_Done = NS_Done +mapStepResult _ NS_Abort = NS_Abort + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +-- So if it returns NS_Done, it means that both steppers are satisfied +composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev + -> NormaliseStepper ev +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper Coercion +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX'. +-- +-- Typically ev is Coercion. +-- +-- If topNormaliseTypeX step plus ty = Just (ev, ty') +-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' +-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn +-- If it returns Nothing then no newtype unwrapping could happen +topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) + -> Type -> Maybe (ev, Type) +topNormaliseTypeX stepper plus ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys + = go rec_nts ev ty' + | otherwise + = Nothing + where + go rec_nts ev ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' + NS_Done -> Just (ev, ty) + NS_Abort -> Nothing + + | otherwise + = Just (ev, ty) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') +-- +-- then (a) @co : ty0 ~ ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' +topNormaliseNewType_maybe ty + = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty + +{- +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ +-} + +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType + +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType + +{- +%************************************************************************ +%* * + "Lifting" substitution + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = K (a -> Maybe a) + g :: T t1 ~ T t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = Nth 0 g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: \/k. \/a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> Nth 0 g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftingContext = LC TCvSubst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt + -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions*. + -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. + +-- like liftCoSubstWith, but allows for existentially-bound types as well +liftCoSubstWithEx :: Role -- desired role for output coercion + -> [TyVar] -- universally quantified tyvars + -> [Coercion] -- coercions to substitute for those + -> [TyCoVar] -- existentially quantified tycovars + -> [Type] -- types and coercions to be bound to ex vars + -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) +liftCoSubstWithEx role univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) + psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) + in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = mkReflCo r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext subst = LC subst emptyVarEnv + +-- | Extend a lifting context with a new mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext + -- mappings to reflexive coercions are just substitutions +extendLiftingContext (LC subst env) tv arg + | Just (ty, _) <- isReflCo_maybe arg + = LC (extendTCvSubst subst tv ty) env + | otherwise + = LC subst (extendVarEnv env tv arg) + +-- | Extend a lifting context with a new mapping, and extend the in-scope set +extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ to this coercion + -> LiftingContext +extendLiftingContextAndInScope (LC subst env) tv co + = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + +-- | Extend a lifting context with existential-variable bindings. +-- See Note [extendLiftingContextEx] +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + | isTyVar v + = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v $ + mkGReflRightCo Nominal + ty + (ty_co_subst lc Nominal (tyVarKind v))) + in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + ASSERT( isCoVar v ) + let (_, _, s1, s2, r) = coVarKindsTypesRole v + lift_s1 = ty_co_subst lc r s1 + lift_s2 = ty_co_subst lc r s2 + kco = mkTyConAppCo Nominal (equalityTyCon r) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv + +-- | Like 'substForAllCoBndr', but works on a lifting context +substForAllCoBndrUsingLC :: Bool + -> (Coercion -> Coercion) + -> LiftingContext -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst lc role ty + = go role ty + where + go :: Role -> Type -> Coercion + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) + go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) + go r t@(ForAllTy (Bndr v _) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v + body_co = ty_co_subst lc' r ty in + if isTyVar v' || almostDevoidCoVarOfCo v' body_co + -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo + -- imposes an extra restriction on where a covar can appear. See last + -- wrinkle in Note [Unused coercion variable in ForAllCo]. + -- We specifically check for this and panic because we know that + -- there's a hole in the type system here, and we'd rather panic than + -- fall into it. + then mkForAllCo v' h body_co + else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) + go r ty@(LitTy {}) = ASSERT( r == Nominal ) + mkNomReflCo ty + go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. +-} + +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg + + | otherwise + = Just $ mkReflCo r (substTyVar subst v) + +{- Note [liftCoSubstVarBndr] + +callback: + We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in + FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type + in snd. + However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and + ignore the fourth component of the return value. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) +liftCoSubstVarBndr lc tv + = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in + (lc', tv', h) + where + callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, CoercionN, a) +liftCoSubstVarBndrUsing fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, CoercionN, a) +liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isTyVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, eta, stuff ) + where + old_kind = tyVarKind old_var + (eta, stuff) = fun lc old_kind + k1 = coercionLKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, CoercionN, a) +liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isCoVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, kind_co, stuff ) + where + old_kind = coVarKind old_var + (eta, stuff) = fun lc old_kind + k1 = coercionLKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkNthCo role 2 eta' + eta2 = mkNthCo role 3 eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + kind_co = mkTyConAppCo Nominal (equalityTyCon role) + [ mkKindCo co1, mkKindCo co2 + , co1 , co2 ] + lifted = mkProofIrrelCo Nominal kind_co co1 co2 + + new_cenv = extendVarEnv cenv old_var lifted + +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env + +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co + +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co + +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo + +lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env + +lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env + +liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft = liftEnvSubst pFst + +liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight = liftEnvSubst pSnd + +liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst selector subst lc_env + = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + where + pairs = nonDetUFMToList lc_env + -- It's OK to use nonDetUFMToList here because we + -- immediately forget the ordering by creating + -- a VarEnv + (tpairs, cpairs) = partitionWith ty_or_co pairs + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) + +-- | Extract the underlying substitution from the LiftingContext +lcTCvSubst :: LiftingContext -> TCvSubst +lcTCvSubst (LC subst _) = subst + +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = getTCvInScope subst + +{- +%************************************************************************ +%* * + Sequencing on coercions +%* * +%************************************************************************ +-} + +seqMCo :: MCoercion -> () +seqMCo MRefl = () +seqMCo (MCo co) = seqCo co + +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k + `seq` seqCo co +seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 +seqCo (CoVarCo cv) = cv `seq` () +seqCo (HoleCo h) = coHoleCoVar h `seq` () +seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos +seqCo (UnivCo p r t1 t2) + = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo r n co) = r `seq` n `seq` seqCo co +seqCo (LRCo lr co) = lr `seq` seqCo co +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (KindCo co) = seqCo co +seqCo (SubCo co) = seqCo co +seqCo (AxiomRuleCo _ cs) = seqCos cs + +seqProv :: UnivCoProvenance -> () +seqProv (PhantomProv co) = seqCo co +seqProv (ProofIrrelProv co) = seqCo co +seqProv (PluginProv _) = () + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ +-} + +-- | Apply 'coercionKind' to multiple 'Coercion's +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys + +-- | Get a coercion's kind and role. +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole co = (coercionKind co, coercionRole co) + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: Coercion -> Pair Type +coercionKind co = Pair (coercionLKind co) (coercionRKind co) + +coercionLKind :: Coercion -> Type +coercionLKind co + = go co + where + go (Refl ty) = ty + go (GRefl _ ty _) = ty + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) + go (FunCo _ co1 co2) = mkVisFunTy (go co1) (go co2) + go (CoVarCo cv) = coVarLType cv + go (HoleCo h) = coVarLType (coHoleCoVar h) + go (UnivCo _ _ ty1 _) = ty1 + go (SymCo co) = coercionRKind co + go (TransCo co1 _) = go co1 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (NthCo _ d co) = go_nth d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos + + go_ax_inst ax ind tys + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs } <- coAxiomNthBranch ax ind + , let (tys1, cotys1) = splitAtList tvs tys + cos1 = map stripCoercionTy cotys1 + = ASSERT( tys `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + mkTyConApp (coAxiomTyCon ax) lhs + + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + +go_nth :: Int -> Type -> Type +go_nth d ty + | Just args <- tyConAppArgs_maybe ty + = ASSERT( args `lengthExceeds` d ) + args `getNth` d + + | d == 0 + , Just (tv,_) <- splitForAllTy_maybe ty + = tyVarKind tv + + | otherwise + = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty) + +coercionRKind :: Coercion -> Type +coercionRKind co + = go co + where + go (Refl ty) = ty + go (GRefl _ ty MRefl) = ty + go (GRefl _ ty (MCo co1)) = mkCastTy ty co1 + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (CoVarCo cv) = coVarRType cv + go (HoleCo h) = coVarRType (coHoleCoVar h) + go (FunCo _ co1 co2) = mkVisFunTy (go co1) (go co2) + go (UnivCo _ _ _ ty2) = ty2 + go (SymCo co) = coercionLKind co + go (TransCo _ co2) = go co2 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (NthCo _ d co) = go_nth d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pSnd $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos + + go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar + | isGReflCo k_co = mkTyCoInvForAllTy tv1 (go co1) + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = go_forall empty_subst co + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + + go_ax_inst ax ind tys + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , let (tys2, cotys2) = splitAtList tvs tys + cos2 = map stripCoercionTy cotys2 + = ASSERT( tys `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + substTyWith tvs tys2 $ + substTyWithCoVars cvs cos2 rhs + + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + + go_forall subst (ForAllCo tv1 k_co co) + -- See Note [Nested ForAllCos] + | isTyVar tv1 + = mkInvForAllTy tv2 (go_forall subst' co) + where + k2 = coercionRKind k_co + tv2 = setTyVarKind tv1 (substTy subst k2) + subst' | isGReflCo k_co = extendTCvInScope subst tv1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + TyVarTy tv2 `mkCastTy` mkSymCo k_co + + go_forall subst (ForAllCo cv1 k_co co) + | isCoVar cv1 + = mkTyCoInvForAllTy cv2 (go_forall subst' co) + where + k2 = coercionRKind k_co + r = coVarRole cv1 + eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) + eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendTCvInScope subst cv1 + | otherwise = extendCvSubst (extendTCvInScope subst cv2) + cv1 n_subst + + go_forall subst other_co + -- when other_co is not a ForAllCo + = substTy subst (go other_co) + +{- + +Note [Nested ForAllCos] +~~~~~~~~~~~~~~~~~~~~~~~ + +Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an +co)...) )`. We do not want to perform `n` single-type-variable +substitutions over the kind of `co`; rather we want to do one substitution +which substitutes for all of `a1`, `a2` ... simultaneously. If we do one +at a time we get the performance hole reported in #11735. + +Solution: gather up the type variables for nested `ForAllCos`, and +substitute for them all at once. Remarkably, for #11735 this single +change reduces /total/ compile time by a factor of more than ten. + +-} + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl _) = Nominal + go (GRefl r _ _) = r + go (TyConAppCo r _ _) = r + go (AppCo co1 _) = go co1 + go (ForAllCo _ _ co) = go co + go (FunCo r _ _) = r + go (CoVarCo cv) = coVarRole cv + go (HoleCo h) = coVarRole (coHoleCoVar h) + go (AxiomInstCo ax _ _) = coAxiomRole ax + go (UnivCo _ r _ _) = r + go (SymCo co) = go co + go (TransCo co1 _co2) = go co1 + go (NthCo r _d _co) = r + go (LRCo {}) = Nominal + go (InstCo co _) = go co + go (KindCo {}) = Nominal + go (SubCo _) = Representational + go (AxiomRuleCo ax _) = coaxrRole ax + +{- +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +But this is a *quadratic* algorithm, and the blew up #5631. +So it's very important to do the substitution simultaneously; +cf Type.piResultTys (which in fact we call here). + +-} + +-- | Makes a coercion type from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkPrimEqPred +mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] + +mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type +mkHeteroCoercionType Nominal = mkHeteroPrimEqPred +mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred +mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" + +-- | Creates a primitive type equality predicate. +-- Invariant: the types are not Coercions +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Makes a lifted equality predicate at the given role +mkPrimEqPredRole :: Role -> Type -> Type -> PredType +mkPrimEqPredRole Nominal = mkPrimEqPred +mkPrimEqPredRole Representational = mkReprPrimEqPred +mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" + +-- | Creates a primitive type equality predicate with explicit kinds +mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + +-- | Creates a primitive representational type equality predicate +-- with explicit kinds +mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroReprPrimEqPred k1 k2 ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + +mkReprPrimEqPred :: Type -> Type -> Type +mkReprPrimEqPred ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Assuming that two types are the same, ignoring coercions, find +-- a nominal coercion between the types. This is useful when optimizing +-- transitivity over coercion applications, where splitting two +-- AppCos might yield different kinds. See Note [EtaAppCo] in +-- GHC.Core.Coercion.Opt. +buildCoercion :: Type -> Type -> CoercionN +buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + go (CastTy ty1 co) ty2 + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceLeftCo r ty1 co co' + + go ty1 (CastTy ty2 co) + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceRightCo r ty2 co co' + + go ty1@(TyVarTy tv1) _tyvarty + = ASSERT( case _tyvarty of + { TyVarTy tv2 -> tv1 == tv2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (FunTy { ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_arg = arg2, ft_res = res2 }) + = mkFunCo Nominal (go arg1 arg2) (go res1 res2) + + go (TyConApp tc1 args1) (TyConApp tc2 args2) + = ASSERT( tc1 == tc2 ) + mkTyConAppCo Nominal tc1 (zipWith go args1 args2) + + go (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) + | isTyVar tv1 + = ASSERT( isTyVar tv2 ) + mkForAllCo tv1 kind_co (go ty1 ty2') + where kind_co = go (tyVarKind tv1) (tyVarKind tv2) + in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTyWithInScope in_scope [tv2] + [mkTyVarTy tv1 `mkCastTy` kind_co] + ty2 + + go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) + = ASSERT( isCoVar cv1 && isCoVar cv2 ) + mkForAllCo cv1 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkNthCo r 2 kind_co' + eta2 = mkNthCo r 3 kind_co' + + subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 + + go ty1@(LitTy lit1) _lit2 + = ASSERT( case _lit2 of + { LitTy lit2 -> lit1 == lit2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (CoercionTy co1) (CoercionTy co2) + = mkProofIrrelCo Nominal kind_co co1 co2 + where + kind_co = go (coercionType co1) (coercionType co2) + + go ty1 ty2 + = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 + , ppr ty1, ppr ty2 ]) + +{- +%************************************************************************ +%* * + Simplifying types +%* * +%************************************************************************ + +The function below morally belongs in TcFlatten, but it is used also in +FamInstEnv, and so lives here. + +Note [simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (F2) of Note [Flattening] says that flattening is homogeneous. +This causes some trouble when flattening a function applied to a telescope +of arguments, perhaps with dependency. For example, suppose + + type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] + +and we wish to flatten the args of (with kind applications explicit) + + F a b (Just a c) (Right a b d) False + +where all variables are skolems and + + a :: Type + b :: Type + c :: a + d :: k + + [G] aco :: a ~ fa + [G] bco :: b ~ fb + [G] cco :: c ~ fc + [G] dco :: d ~ fd + +The first step is to flatten all the arguments. This is done before calling +simplifyArgsWorker. We start from + + a + b + Just a c + Right a b d + False + +and get + + (fa, co1 :: fa ~ a) + (fb, co2 :: fb ~ b) + (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) + (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) + (False, co5 :: False ~ False) + +where + co6 :: Maybe fa ~ Maybe a + co7 :: Either fa fb ~ Either a b + +We now process the flattened args in left-to-right order. The first two args +need no further processing. But now consider the third argument. Let f3 = the flattened +result, Just fa (fc |> aco) |> co6. +This f3 flattened argument has kind (Maybe a), due to +(F2). And yet, when we build the application (F fa fb ...), we need this +argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. +The coercion to use is +determined by the kind of F: we see in F's kind that the third argument has +kind Maybe j. Critically, we also know that the argument corresponding to j +(in our example, a) flattened with a coercion co1. We can thus know the +coercion needed for the 3rd argument is (Maybe (sym co1)), thus building +(f3 |> Maybe (sym co1)) + +More generally, we must use the Lifting Lemma, as implemented in +Coercion.liftCoSubst. As we work left-to-right, any variable that is a +dependent parameter (j and k, in our example) gets mapped in a lifting context +to the coercion that is output from flattening the corresponding argument (co1 +and co2, in our example). Then, after flattening later arguments, we lift the +kind of these arguments in the lifting context that we've be building up. +This coercion is then used to keep the result of flattening well-kinded. + +Working through our example, this is what happens: + + 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, + because the binder associated with the first argument has a closed type (no + variables). + + 2. Extend the LC with [k |-> co2]. No casting to do. + + 3. Lifting the kind (Maybe j) with our LC + yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to + F. + + 4. Lifting the kind (Either j k) with our LC + yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th + argument to F, where f4 is the flattened form of argument 4, written above. + + 5. We lift Bool with our LC, getting ; + casting has no effect. + +We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) +has the wrong kind. Its kind is [fb], instead of the original [b]. +So we must use our LC one last time to lift the result kind [k], +getting res_co :: [fb] ~ [b], and we cast our result. + +Accordingly, the final result is + + F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) + (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) + False + |> [sym bco] + +The res_co (in this case, [sym bco]) +is returned as the third return value from simplifyArgsWorker. + +Note [Last case in simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, +because that case is first. We've run out of +binders. But perhaps inner_ki is a tyvar that has been instantiated with a +Π-type. + +Here is an example. + + a :: forall (k :: Type). k -> k + type family Star + Proxy :: forall j. j -> Type + axStar :: Star ~ Type + type family NoWay :: Bool + axNoWay :: NoWay ~ False + bo :: Type + [G] bc :: bo ~ Bool (in inert set) + + co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) + co = forall (j :: sym axStar). ( -> sym axStar) + + We are flattening: + a (forall (j :: Star). (j |> axStar) -> Star) -- 1 + (Proxy |> co) -- 2 + (bo |> sym axStar) -- 3 + (NoWay |> sym bc) -- 4 + :: Star + +First, we flatten all the arguments (before simplifyArgsWorker), like so: + + (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ + (forall (j :: Star). (j |> axStar) -> Star)) -- 1 + (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 + (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 + (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 + +Then we do the process described in Note [simplifyArgsWorker]. + +1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we + don't use it. But we do build a lifting context [k -> co1] (where co1 is a + result of flattening an argument, written above). + +2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). + This is not a dependent argument, so we don't extend the lifting context. + +Now we need to deal with argument (3). +The way we normally proceed is to lift the kind of the binder, to see whether +it's dependent. +But here, the remainder of the kind of `a` that we're left with +after processing two arguments is just `k`. + +The way forward is look up k in the lifting context, getting co1. If we're at +all well-typed, co1 will be a coercion between Π-types, with at least one binder. +So, let's +decompose co1 with decomposePiCos. This decomposition needs arguments to use +to instantiate any kind parameters. Look at the type of co1. If we just +decomposed it, we would end up with coercions whose types include j, which is +out of scope here. Accordingly, decomposePiCos takes a list of types whose +kinds are the *right-hand* types in the decomposed coercion. (See comments on +decomposePiCos.) Because the flattened types have unflattened kinds (because +flattening is homogeneous), passing the list of flattened types to decomposePiCos +just won't do: later arguments' kinds won't be as expected. So we need to get +the *unflattened* types to pass to decomposePiCos. We can do this easily enough +by taking the kind of the argument coercions, passed in originally. + +(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. +But that function is already gnarly, and taking the right-hand types is correct +at its other call sites, which are much more common than this one.) + +(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its +behavior into simplifyArgsWorker. This would work, I think, but then all of the +complication of decomposePiCos would end up layered on top of all the complication +here. Please, no.) + +(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker +so that we don't have to recreate them. But that would complicate the interface +of this function to handle a very dark, dark corner case. Better to keep our +demons to ourselves here instead of exposing them to callers. This decision is +easily reversed if there is ever any performance trouble due to the call of +coercionKind.) + +So we now call + + decomposePiCos co1 + (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) + [bo |> sym axStar, NoWay |> sym bc] + +to get + + co5 :: Star ~ Type + co6 :: (j |> axStar) ~ (j |> co5), substituted to + (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) + == bo ~ bo + res_co :: Type ~ Star + +We then use these casts on (the flattened) (3) and (4) to get + + (Bool |> sym axStar |> co5 :: Type) -- (C3) + (False |> sym bc |> co6 :: bo) -- (C4) + +We can simplify to + + Bool -- (C3) + (False |> sym bc :: bo) -- (C4) + +Of course, we still must do the processing in Note [simplifyArgsWorker] to finish +the job. We thus want to recur. Our new function kind is the left-hand type of +co1 (gotten, recall, by lifting the variable k that was the return kind of the +original function). Why the left-hand type (as opposed to the right-hand type)? +Because we have casted all the arguments according to decomposePiCos, which gets +us from the right-hand type to the left-hand one. We thus recur with that new +function kind, zapping our lifting context, because we have essentially applied +it. + +This recursive call returns ([Bool, False], [...], Refl). The Bool and False +are the correct arguments we wish to return. But we must be careful about the +result coercion: our new, flattened application will have kind Type, but we +want to make sure that the result coercion casts this back to Star. (Why? +Because we started with an application of kind Star, and flattening is homogeneous.) + +So, we have to twiddle the result coercion appropriately. + +Let's check whether this is well-typed. We know + + a :: forall (k :: Type). k -> k + + a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type + + a (forall j. j -> Type) + Proxy + :: forall j. j -> Type + + a (forall j. j -> Type) + Proxy + Bool + :: Bool -> Type + + a (forall j. j -> Type) + Proxy + Bool + False + :: Type + + a (forall j. j -> Type) + Proxy + Bool + False + |> res_co + :: Star + +as desired. + +Whew. + +Historical note: I (Richard E) once thought that the final part of the kind +had to be a variable k (as in the example above). But it might not be: it could +be an application of a variable. Here is the example: + + let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) + k :: Type + x :: k + + flatten (f @Type @((->) k) x) + +After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` +is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. + +-} + + +-- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv. +-- See Note [simplifyArgsWorker] +{-# INLINE simplifyArgsWorker #-} +simplifyArgsWorker :: [TyCoBinder] -> Kind + -- the binders & result kind (not a Π-type) of the function applied to the args + -- list of binders can be shorter or longer than the list of args + -> TyCoVarSet -- free vars of the args + -> [Role] -- list of roles, r + -> [(Type, Coercion)] -- flattened type arguments, arg + -- each comes with the coercion used to flatten it, + -- with co :: flattened_type ~ original_type + -> ([Type], [Coercion], CoercionN) +-- Returns (xis, cos, res_co), where each co :: xi ~ arg, +-- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args +-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), +-- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. +-- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this +-- function is all about. That is, (f xis), where xis are the returned arguments, *is* +-- well kinded. +simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs + orig_roles orig_simplified_args + = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args + where + orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs + + go :: [Type] -- Xis accumulator, in reverse order + -> [Coercion] -- Coercions accumulator, in reverse order + -- These are in 1-to-1 correspondence + -> LiftingContext -- mapping from tyvars to flattening coercions + -> [TyCoBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> [Role] -- Roles at which to flatten these ... + -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions + -> ([Type], [Coercion], CoercionN) + go acc_xis acc_cos lc binders inner_ki _ [] + = (reverse acc_xis, reverse acc_cos, kind_co) + where + final_kind = mkPiTys binders inner_ki + kind_co = liftCoSubst Nominal lc final_kind + + go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) + = -- By Note [Flattening] in TcFlatten invariant (F2), + -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be + -- used as an argument to a function whose kind is different, if + -- earlier arguments have been flattened to new types. We thus + -- need a coercion (kind_co :: old_kind ~ new_kind). + -- + -- The bangs here have been observed to improve performance + -- significantly in optimized builds. + let kind_co = mkSymCo $ + liftCoSubst Nominal lc (tyCoBinderType binder) + !casted_xi = xi `mkCastTy` kind_co + casted_co = mkCoherenceLeftCo role xi kind_co co + + -- now, extend the lifting context with the new binding + !new_lc | Just tv <- tyCoBinderVar_maybe binder + = extendLiftingContextAndInScope lc tv casted_co + | otherwise + = lc + in + go (casted_xi : acc_xis) + (casted_co : acc_cos) + new_lc + binders + inner_ki + roles + args + + + -- See Note [Last case in simplifyArgsWorker] + go acc_xis acc_cos lc [] inner_ki roles args + = let co1 = liftCoSubst Nominal lc inner_ki + co1_kind = coercionKind co1 + unflattened_tys = map (coercionRKind . snd) args + (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys + casted_args = ASSERT2( equalLength args arg_cos + , ppr args $$ ppr arg_cos ) + [ (casted_xi, casted_co) + | ((xi, co), arg_co, role) <- zip3 args arg_cos roles + , let casted_xi = xi `mkCastTy` arg_co + casted_co = mkCoherenceLeftCo role xi arg_co co ] + -- In general decomposePiCos can return fewer cos than tys, + -- but not here; because we're well typed, there will be enough + -- binders. Note that decomposePiCos does substitutions, so even + -- if the original substitution results in something ending with + -- ... -> k, that k will be substituted to perhaps reveal more + -- binders. + zapped_lc = zapLiftingContext lc + Pair flattened_kind _ = co1_kind + (bndrs, new_inner) = splitPiTys flattened_kind + + (xis_out, cos_out, res_co_out) + = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args + in + (xis_out, cos_out, res_co_out `mkTransCo` res_co) + + go _ _ _ _ _ _ _ = panic + "simplifyArgsWorker wandered into deeper water than usual" + -- This debug information is commented out because leaving it in + -- causes a ~2% increase in allocations in T9872d. + -- That's independent of the analogous case in flatten_args_fast + -- in TcFlatten: + -- each of these causes a 2% increase on its own, so commenting them + -- both out gives a 4% decrease in T9872d. + {- + + (vcat [ppr orig_binders, + ppr orig_inner_ki, + ppr (take 10 orig_roles), -- often infinite! + ppr orig_tys]) + -} + +{- +%************************************************************************ +%* * + Coercion holes +%* * +%************************************************************************ +-} + +bad_co_hole_ty :: Type -> Monoid.Any +bad_co_hole_co :: Coercion -> Monoid.Any +(bad_co_hole_ty, _, bad_co_hole_co, _) + = foldTyCo folder () + where + folder = TyCoFolder { tcf_view = const Nothing + , tcf_tyvar = const2 (Monoid.Any False) + , tcf_covar = const2 (Monoid.Any False) + , tcf_hole = const hole + , tcf_tycobinder = const2 + } + + const2 :: a -> b -> c -> a + const2 x _ _ = x + + hole :: CoercionHole -> Monoid.Any + hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True + hole _ = Monoid.Any False + +-- | Is there a blocking coercion hole in this type? See +-- TcCanonical Note [Equalities with incompatible kinds] +badCoercionHole :: Type -> Bool +badCoercionHole = Monoid.getAny . bad_co_hole_ty + +-- | Is there a blocking coercion hole in this coercion? See +-- TcCanonical Note [Equalities with incompatible kinds] +badCoercionHoleCo :: Coercion -> Bool +badCoercionHoleCo = Monoid.getAny . bad_co_hole_co diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Coercion where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep +import {-# SOURCE #-} GHC.Core.TyCon + +import GHC.Types.Basic ( LeftOrRight ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import Pair +import Util + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: Coercion -> Coercion -> Coercion +mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkNomReflCo :: Type -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion + +isGReflCo :: Coercion -> Bool +isReflCo :: Coercion -> Bool +isReflexiveCo :: Coercion -> Bool +decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +data LiftingContext +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +seqCo :: Coercion -> () + +coercionKind :: Coercion -> Pair Type +coercionLKind :: Coercion -> Type +coercionRKind :: Coercion -> Type +coercionType :: Coercion -> Type diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -0,0 +1,577 @@ +-- (c) The University of Glasgow 2012 + +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, + ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} + +-- | Module for coercion axioms, used to represent type family instances +-- and newtypes + +module GHC.Core.Coercion.Axiom ( + BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), + manyBranches, unbranched, + fromBranches, numBranches, + mapAccumBranches, + + CoAxiom(..), CoAxBranch(..), + + toBranchedAxiom, toUnbranchedAxiom, + coAxiomName, coAxiomArity, coAxiomBranches, + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..), fsFromRole, + + CoAxiomRule(..), TypeEqn, + BuiltInSynFamily(..) + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import Outputable +import FastString +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Var +import Util +import Binary +import Pair +import GHC.Types.Basic +import Data.Typeable ( Typeable ) +import GHC.Types.SrcLoc +import qualified Data.Data as Data +import Data.Array +import Data.List ( mapAccumL ) + +#include "HsVersions.h" + +{- +Note [Coercion axiom branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to allow closed type families, an axiom needs to contain an +ordered list of alternatives, called branches. The kind of the coercion built +from an axiom is determined by which index is used when building the coercion +from the axiom. + +For example, consider the axiom derived from the following declaration: + +type family F a where + F [Int] = Bool + F [a] = Double + F (a b) = Char + +This will give rise to this axiom: + +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char + } + +The axiom is used with the AxiomInstCo constructor of Coercion. If we wish +to have a coercion showing that F (Maybe Int) ~ Char, it will look like + +axF[2] <*> :: F (Maybe Int) ~ Char +-- or, written using concrete-ish syntax -- +AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] + +Note that the index is 0-based. + +For type-checking, it is also necessary to check that no previous pattern +can unify with the supplied arguments. After all, it is possible that some +of the type arguments are lambda-bound type variables whose instantiation may +cause an earlier match among the branches. We wish to prohibit this behavior, +so the type checker rules out the choice of a branch where a previous branch +can unify. See also [Apartness] in GHC.Core.FamInstEnv. + +For example, the following is malformed, where 'a' is a lambda-bound type +variable: + +axF[2] <*> :: F (a Bool) ~ Char + +Why? Because a might be instantiated with [], meaning that branch 1 should +apply, not branch 2. This is a vital consistency check; without it, we could +derive Int ~ Bool, and that is a Bad Thing. + +Note [Branched axioms] +~~~~~~~~~~~~~~~~~~~~~~ +Although a CoAxiom has the capacity to store many branches, in certain cases, +we want only one. These cases are in data/newtype family instances, newtype +coercions, and type family instances. +Furthermore, these unbranched axioms are used in a +variety of places throughout GHC, and it would difficult to generalize all of +that code to deal with branched axioms, especially when the code can be sure +of the fact that an axiom is indeed a singleton. At the same time, it seems +dangerous to assume singlehood in various places through GHC. + +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The branches +are stored using a special datatype, declared below, that ensures that the +type variable is accurate. + +************************************************************************ +* * + Branches +* * +************************************************************************ +-} + +type BranchIndex = Int -- The index of the branch in the list of branches + -- Counting from zero + +-- promoted data type +data BranchFlag = Branched | Unbranched +type Branched = 'Branched +type Unbranched = 'Unbranched +-- By using type synonyms for the promoted constructors, we avoid needing +-- DataKinds and the promotion quote in client modules. This also means that +-- we don't need to export the term-level constructors, which should never be used. + +newtype Branches (br :: BranchFlag) + = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } +type role Branches nominal + +manyBranches :: [CoAxBranch] -> Branches Branched +manyBranches brs = ASSERT( snd bnds >= fst bnds ) + MkBranches (listArray bnds brs) + where + bnds = (0, length brs - 1) + +unbranched :: CoAxBranch -> Branches Unbranched +unbranched br = MkBranches (listArray (0, 0) [br]) + +toBranched :: Branches br -> Branches Branched +toBranched = MkBranches . unMkBranches + +toUnbranched :: Branches br -> Branches Unbranched +toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) + MkBranches arr + +fromBranches :: Branches br -> [CoAxBranch] +fromBranches = elems . unMkBranches + +branchesNth :: Branches br -> BranchIndex -> CoAxBranch +branchesNth (MkBranches arr) n = arr ! n + +numBranches :: Branches br -> Int +numBranches (MkBranches arr) = snd (bounds arr) + 1 + +-- | The @[CoAxBranch]@ passed into the mapping function is a list of +-- all previous branches, reversed +mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) + -> Branches br -> Branches br +mapAccumBranches f (MkBranches arr) + = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_branches cur_branch = ( cur_branch : prev_branches + , f prev_branches cur_branch ) + + +{- +************************************************************************ +* * + Coercion axioms +* * +************************************************************************ + +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on +the unification algorithm.) Although we could theoretically compute +compatibility on the fly, this is silly, so we store it in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. + +Note [CoAxioms are homogeneous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All axioms must be *homogeneous*, meaning that the kind of the LHS must +match the kind of the RHS. In practice, this means: + + Given a CoAxiom { co_ax_tc = ax_tc }, + for every branch CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }: + typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs + +This is checked in FamInstEnv.mkCoAxBranch. +-} + +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data CoAxiom br + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- Unique identifier + , co_ax_name :: Name -- Name for pretty-printing + , co_ax_role :: Role -- Role of the axiom's equality + , co_ax_tc :: TyCon -- The head of the LHS patterns + -- e.g. the newtype or family tycon + , co_ax_branches :: Branches br -- The branches that form this axiom + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] + -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. + } + +data CoAxBranch + = CoAxBranch + { cab_loc :: SrcSpan -- Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars + -- See Note [CoAxBranch type variables] + -- cab_tvs and cab_lhs may be eta-reduded; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] -- Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in TcTyClsDecls + , cab_roles :: [Role] -- See Note [CoAxBranch roles] + , cab_lhs :: [Type] -- Type patterns to match against + , cab_rhs :: Type -- Right-hand side of the equality + -- See Note [CoAxioms are homogeneous] + , cab_incomps :: [CoAxBranch] -- The previous incompatible branches + -- See Note [Storing compatibility] + } + deriving Data.Data + +toBranchedAxiom :: CoAxiom br -> CoAxiom Branched +toBranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toBranched branches) implicit + +toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched +toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toUnbranched branches) implicit + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) + +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = branchesNth bs index + +coAxiomArity :: CoAxiom br -> BranchIndex -> Arity +coAxiomArity ax index + = length tvs + length cvs + where + CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index + +coAxiomName :: CoAxiom br -> Name +coAxiomName = co_ax_name + +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + +coAxiomBranches :: CoAxiom br -> Branches br +coAxiomBranches = co_ax_branches + +coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch +coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) + | snd (bounds arr) == 0 + = Just $ arr ! 0 + | otherwise + = Nothing + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) + = arr ! 0 + +coAxiomTyCon :: CoAxiom br -> TyCon +coAxiomTyCon = co_ax_tc + +coAxBranchTyVars :: CoAxBranch -> [TyVar] +coAxBranchTyVars = cab_tvs + +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + +coAxBranchLHS :: CoAxBranch -> [Type] +coAxBranchLHS = cab_lhs + +coAxBranchRHS :: CoAxBranch -> Type +coAxBranchRHS = cab_rhs + +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + +coAxBranchSpan :: CoAxBranch -> SrcSpan +coAxBranchSpan = cab_loc + +isImplicitCoAxiom :: CoAxiom br -> Bool +isImplicitCoAxiom = co_ax_implicit + +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +-- See Note [Compatibility checking] in GHC.Core.FamInstEnv +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + +{- +Note [CoAxBranch type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of a CoAxBranch of an associated type-family instance, +we use the *same* type variables (where possible) as the +enclosing class or instance. Consider + + instance C Int [z] where + type F Int [z] = ... -- Second param must be [z] + +In the CoAxBranch in the instance decl (F Int [z]) we use the +same 'z', so that it's easy to check that that type is the same +as that in the instance header. + +So, unlike FamInsts, there is no expectation that the cab_tvs +are fresh wrt each other, or any other CoAxBranch. + +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + +Note [CoAxiom locations] +~~~~~~~~~~~~~~~~~~~~~~~~ +The source location of a CoAxiom is stored in two places in the +datatype tree. + * The first is in the location info buried in the Name of the + CoAxiom. This span includes all of the branches of a branched + CoAxiom. + * The second is in the cab_loc fields of the CoAxBranches. + +In the case of a single branch, we can extract the source location of +the branch from the name of the CoAxiom. In other cases, we need an +explicit SrcSpan to correctly store the location of the equation +giving rise to the FamInstBranch. + +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in GHC.Driver.Types +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration + +Note [Eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. + +From the 'newtype instance' you might think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +----- Bottom line ------ + +For a CoAxBranch for a data family instance with representation +TyCon rep_tc: + + - cab_tvs (of its CoAxiom) may be shorter + than tyConTyVars of rep_tc. + + - cab_lhs may be shorter than tyConArity of the family tycon + i.e. LHS is unsaturated + + - cab_rhs will be (rep_tc cab_tvs) + i.e. RHS is un-saturated + + - This eta reduction happens for data instances as well + as newtype instances. Here we want to eta-reduce the data family axiom. + + - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. + +But for a /type/ family + - cab_lhs has the exact arity of the family tycon + +There are certain situations (e.g., pretty-printing) where it is necessary to +deal with eta-expanded data family instances. For these situations, the +cab_eta_tvs field records the stuff that has been eta-reduced away. +So if we have + axiom forall a b. F [a->b] = D b a +and cab_eta_tvs is [p,q], then the original user-written definition +looked like + axiom forall a b p q. F [a->b] p q = D b a p q +(See #9692, #14179, and #15845 for examples of what can go wrong if +we don't eta-expand when showing things to the user.) + +(See also Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate +and deals with the axiom connecting a newtype with its representation +type; but it too is eta-reduced.) +-} + +instance Eq (CoAxiom br) where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable (CoAxiom br) where + getUnique = co_ax_unique + +instance Outputable (CoAxiom br) where + ppr = ppr . getName + +instance NamedThing (CoAxiom br) where + getName = co_ax_name + +instance Typeable br => Data.Data (CoAxiom br) where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" + +instance Outputable CoAxBranch where + ppr (CoAxBranch { cab_loc = loc + , cab_lhs = lhs + , cab_rhs = rhs }) = + text "CoAxBranch" <+> parens (ppr loc) <> colon + <+> brackets (fsep (punctuate comma (map pprType lhs))) + <+> text "=>" <+> pprType rhs + +{- +************************************************************************ +* * + Roles +* * +************************************************************************ + +Roles are defined here to avoid circular dependencies. +-} + +-- See Note [Roles] in GHC.Core.Coercion +-- defined here to avoid cyclic dependency with GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data.Data) + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in RdrHsSyn +fsFromRole :: Role -> FastString +fsFromRole Nominal = fsLit "nominal" +fsFromRole Representational = fsLit "representational" +fsFromRole Phantom = fsLit "phantom" + +instance Outputable Role where + ppr = ftext . fsFromRole + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +{- +************************************************************************ +* * + CoAxiomRule + Rules for building Evidence +* * +************************************************************************ + +Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: + + forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 + +My intention is to reuse these for both (~) and (~#). +The short-term plan is to use this datatype to represent the type-nat axioms. +In the longer run, it may be good to unify this and `CoAxiom`, +as `CoAxiom` is the special case when there are no assumptions. +-} + +-- | A more explicit representation for `t1 ~ t2`. +type TypeEqn = Pair Type + +-- | For now, we work only with nominal equality. +data CoAxiomRule = CoAxiomRule + { coaxrName :: FastString + , coaxrAsmpRoles :: [Role] -- roles of parameter equations + , coaxrRole :: Role -- role of resulting equation + , coaxrProves :: [TypeEqn] -> Maybe TypeEqn + -- ^ coaxrProves returns @Nothing@ when it doesn't like + -- the supplied arguments. When this happens in a coercion + -- that means that the coercion is ill-formed, and Core Lint + -- checks for that. + } + +instance Data.Data CoAxiomRule where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiomRule" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiomRule" + +instance Uniquable CoAxiomRule where + getUnique = getUnique . coaxrName + +instance Eq CoAxiomRule where + x == y = coaxrName x == coaxrName y + +instance Ord CoAxiomRule where + compare x y = compare (coaxrName x) (coaxrName y) + +instance Outputable CoAxiomRule where + ppr = ppr . coaxrName + + +-- Type checking of built-in families +data BuiltInSynFamily = BuiltInSynFamily + { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) + , sfInteractTop :: [Type] -> Type -> [TypeEqn] + , sfInteractInert :: [Type] -> Type -> + [Type] -> Type -> [TypeEqn] + } diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -0,0 +1,1206 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.Coercion +import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) +import TcType ( exactTyCoVarsOfType ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import Outputable +import GHC.Core.FamInstEnv ( flattenTys ) +import Pair +import ListSetOps ( getNth ) +import Util +import GHC.Core.Unify +import GHC.Core.InstEnv +import Control.Monad ( zipWithM ) + +{- +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +(1) tv is a type variable +When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. + +Let's look at the typing rules. + +h : k1 ~ k2 +tv:k1 |- g : t1 ~ t2 +----------------------------- +ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) + +g1 : (all tv:k1.t1') ~ (all tv:k2.t2') +g2 : s1 ~ s2 +-------------------- +InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +We thus want some coercion proving this: + + (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) + +If we substitute the *type* tv for the *coercion* +(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. +This is bizarre, +though, because we're substituting a type variable with a coercion. However, +this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion. +We just need to enhance the lifting operation to be able to deal with +an ambient substitution, which is why a LiftingContext stores a TCvSubst. + +(2) cv is a coercion variable +Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +So we substitute the coercion variable c for the coercion +(h1 ~N (n1; h2; sym n2)) in g. +-} + +optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion dflags env co + | hasNoOptCoercion dflags = substCo env co + | otherwise = optCoercion' env co + +optCoercion' :: TCvSubst -> Coercion -> NormalCo +optCoercion' env co + | debugIsOn + = let out_co = opt_co1 lc False co + (Pair in_ty1 in_ty2, in_role) = coercionKindRole co + (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + in + ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && + substTyUnchecked env in_ty2 `eqType` out_ty2 && + in_role == out_role + , text "optCoercion changed types!" + $$ hang (text "in_co:") 2 (ppr co) + $$ hang (text "in_ty1:") 2 (ppr in_ty1) + $$ hang (text "in_ty2:") 2 (ppr in_ty2) + $$ hang (text "out_co:") 2 (ppr out_co) + $$ hang (text "out_ty1:") 2 (ppr out_ty1) + $$ hang (text "out_ty2:") 2 (ppr out_ty2) + $$ hang (text "subst:") 2 (ppr env) ) + out_co + + | otherwise = opt_co1 lc False co + where + lc = mkSubstLiftingContext env + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. All coercions in +-- the lifting context are already optimized (and sym'd if nec'y) +opt_co1 :: LiftingContext + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: LiftingContext + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4_wrap env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4_wrap = opt_co4 +{- +opt_co4_wrap env sym rep r co + = pprTrace "opt_co4_wrap {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + ASSERT( r == coercionRole co ) + let result = opt_co4 env sym rep r co in + pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ + result +-} + +opt_co4 env _ rep r (Refl ty) + = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr Nominal $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env _ rep r (GRefl _r ty MRefl) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env sym rep r (GRefl _r ty (MCo co)) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + if isGReflCo co || isGReflCo co' + then liftCoSubst r' env ty + else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) + where + r' = chooseRole rep r + ty' = substTy (lcSubstLeft env) ty + co' = opt_co4 env False False Nominal co + +opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co + -- surprisingly, we don't have to do anything to the env here. This is + -- because any "lifting" substitutions in the env are tied to ForAllCos, + -- which treat their left and right sides differently. We don't want to + -- exchange them. + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesRepresentational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesRepresentational tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4_wrap env sym rep r co1) + (opt_co4_wrap env sym False Nominal co2) + +opt_co4 env sym rep r (ForAllCo tv k_co co) + = case optForAllCoBndr env sym tv k_co of + (env', tv', k_co') -> mkForAllCo tv' k_co' $ + opt_co4_wrap env' sym rep r co + -- Use the "mk" functions to check for nested Refls + +opt_co4 env sym rep r (FunCo _r co1 co2) + = ASSERT( r == _r ) + if rep + then mkFunCo Representational co1' co2' + else mkFunCo r co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + +opt_co4 env sym rep r (CoVarCo cv) + | Just co <- lookupCoVar (lcTCvSubst env) cv + = opt_co4_wrap (zapLiftingContext env) sym rep r co + + | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] + = mkReflCo (chooseRole rep r) ty1 + + | otherwise + = ASSERT( isCoVar cv1 ) + wrapRole rep r $ wrapSym sym $ + CoVarCo cv1 + + where + Pair ty1 ty2 = coVarTypes cv1 + + cv1 = case lookupInScope (lcInScopeSet env) cv of + Just cv1 -> cv1 + Nothing -> WARN( True, text "opt_co: not in scope:" + <+> ppr cv $$ ppr env) + cv + -- cv1 might have a substituted kind! + +opt_co4 _ _ _ _ (HoleCo h) + = pprPanic "opt_univ fell into a hole" (ppr h) + +opt_co4 env sym rep r (AxiomInstCo con ind cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co4 env sym rep r (UnivCo prov _r t1 t2) + = ASSERT( r == _r ) + opt_univ env sym prov (chooseRole rep r) t1 t2 + +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + in_scope = lcInScopeSet env + +opt_co4 env _sym rep r (NthCo _r n co) + | Just (ty, _) <- isReflCo_maybe co + , Just (_tc, args) <- ASSERT( r == _r ) + splitTyConApp_maybe ty + = liftCoSubst (chooseRole rep r) env (args `getNth` n) + | Just (ty, _) <- isReflCo_maybe co + , n == 0 + , Just (tv, _) <- splitForAllTy_maybe ty + -- works for both tyvar and covar + = liftCoSubst (chooseRole rep r) env (varType tv) + +opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) + = ASSERT( r == r1 ) + opt_co4_wrap env sym rep r (cos `getNth` n) + +opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) + -- works for both tyvar and covar + = ASSERT( r == _r ) + ASSERT( n == 0 ) + opt_co4_wrap env sym rep Nominal eta + +opt_co4 env sym rep r (NthCo _r n co) + | TyConAppCo _ _ cos <- co' + , let nth_co = cos `getNth` n + = if rep && (r == Nominal) + -- keep propagating the SubCo + then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co + else nth_co + + | ForAllCo _ eta _ <- co' + = if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal eta + else eta + + | otherwise + = wrapRole rep r $ NthCo r n co' + where + co' = opt_co1 env sym co + +opt_co4 env sym rep r (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = ASSERT( r == Nominal ) + opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) + | Just pr_co <- splitAppCo_maybe co' + = ASSERT( r == Nominal ) + if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + else pick_lr lr pr_co + | otherwise + = wrapRole rep Nominal $ LRCo lr co' + where + co' = opt_co4_wrap env sym False Nominal co + + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r + +-- See Note [Optimising InstCo] +opt_co4 env sym rep r (InstCo co1 arg) + -- forall over type... + | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 + = opt_co4_wrap (extendLiftingContext env tv + (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) + -- mkSymCo kind_co :: k1 ~ k2 + -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) + -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) + sym rep r co_body + + -- forall over coercion... + | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 + , CoercionTy h1 <- t1 + , CoercionTy h2 <- t2 + = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 + in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution, then re-optimize + + -- forall over type... + | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' + = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' + (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) + False False r' co_body' + + -- forall over coercion... + | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' + , CoercionTy h1' <- t1' + , CoercionTy h2' <- t2' + = let new_co = mk_new_co cv' kind_co' h1' h2' + in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) + False False r' co_body' + + | otherwise = InstCo co1' arg' + where + co1' = opt_co4_wrap env sym rep r co1 + r' = chooseRole rep r + arg' = opt_co4_wrap env sym False Nominal arg + sym_arg = wrapSym sym arg' + + -- Performance note: don't be alarmed by the two calls to coercionKind + -- here, as only one call to coercionKind is actually demanded per guard. + -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used + -- when checking if co1' (i.e., co1 post-optimization) is a forall. + -- + -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' + -- might have an extra Sym at the front (after being optimized) that co1 + -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) + Pair t1 t2 = coercionKind sym_arg + Pair t1' t2' = coercionKind arg' + + mk_new_co cv kind_co h1 h2 + = let -- h1 :: (t1 ~ t2) + -- h2 :: (t3 ~ t4) + -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) + -- n1 :: t1 ~ t3 + -- n2 :: t2 ~ t4 + -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) + r2 = coVarRole cv + kind_co' = downgradeRole r2 Nominal kind_co + n1 = mkNthCo r2 2 kind_co' + n2 = mkNthCo r2 3 kind_co' + in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 + (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) + +opt_co4 env sym _rep r (KindCo co) + = ASSERT( r == Nominal ) + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> opt_co4_wrap env sym False Nominal kco' + -- This might be able to be optimized more to do the promotion + -- and substitution/optimization at the same time + +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4_wrap env sym True Nominal co + +-- This could perhaps be optimized more. +opt_co4 env sym rep r (AxiomRuleCo co cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ + wrapSym sym $ + AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + +{- Note [Optimise CoVarCo to Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (c :: t~t) we can optimise it to Refl. That increases the +chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) + +We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] +in GHC.Core.Coercion. +-} + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + +{- Note [Differing kinds] + ~~~~~~~~~~~~~~~~~~~~~~ +The two types may not have the same kind (although that would be very unusual). +But even if they have the same kind, and the same type constructor, the number +of arguments in a `CoTyConApp` can differ. Consider + + Any :: forall k. k + + Any * Int :: * + Any (*->*) Maybe Int :: * + +Hence the need to compare argument lengths; see #13658 + -} + +opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role + -> Type -> Type -> Coercion +opt_univ env sym (PhantomProv h) _r ty1 ty2 + | sym = mkPhantomCo h' ty2' ty1' + | otherwise = mkPhantomCo h' ty1' ty2' + where + h' = opt_co4 env sym False Nominal h + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ env sym prov role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + , equalLength tys1 tys2 -- see Note [Differing kinds] + -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); + -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps + = let roles = tyConRolesX role tc1 + arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' + + -- can't optimize the AppTy case because we can't build the kind coercions. + + | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + eta = mkUnivCo prov' Nominal k1 k2 + -- eta gets opt'ed soon, but not yet. + ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + + (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + in + mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 + , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = varType cv1 + k2 = varType cv2 + r' = coVarRole cv1 + eta = mkUnivCo prov' Nominal k1 k2 + eta_d = downgradeRole r' Nominal eta + -- eta gets opt'ed soon, but not yet. + n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` + (mkNthCo r' 3 eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + in + mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | otherwise + = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 + ty2 = substTyUnchecked (lcSubstRight env) oty2 + (a, b) | sym = (ty2, ty1) + | otherwise = (ty1, ty2) + in + mkUnivCo prov' role a b + + where + prov' = case prov of + PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco + PluginProv _ -> prov + +------------- +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) + +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 + | isReflCo co1 = co2 + -- optimize when co1 is a Refl Co + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + -- optimize when co2 is a Refl Co + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) + = ASSERT( r1 == r2 ) + fireTransRule "GRefl" in_co1 in_co2 $ + mkGReflRightCo r1 t1 (opt_trans is co1 co2) + +-- Push transitivity through matching destructors +opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) + | d1 == d2 + , coercionRole co1 == coercionRole co2 + , co1 `compatible_co` co2 + = ASSERT( r1 == r2 ) + fireTransRule "PushNth" in_co1 in_co2 $ + mkNthCo r1 d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqCoercion` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) + in_co2@(UnivCo p2 r2 _tyl2 tyr2) + | Just prov' <- opt_trans_prov p1 p2 + = ASSERT( r1 == r2 ) + fireTransRule "UnivCo" in_co1 in_co2 $ + mkUnivCo prov' r1 tyl1 tyr2 + where + -- if the provenances are different, opt'ing will be very confusing + opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) + = Just $ PhantomProv $ opt_trans is kco1 kco2 + opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) + = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 + opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 + opt_trans_prov _ _ = Nothing + +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) + | tc1 == tc2 + = ASSERT( r1 == r2 ) + fireTransRule "PushTyConApp" in_co1 in_co2 $ + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) + = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case + fireTransRule "PushFun" in_co1 in_co2 $ + mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + -- Must call opt_trans_rule_app; see Note [EtaAppCo] + = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = ASSERT( cos1 `equalLength` cos2 ) + fireTransRule "EtaCompL" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = ASSERT( cos1 `equalLength` cos2 ) + fireTransRule "EtaCompR" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +-- Push transitivity inside forall +-- forall over types. +opt_trans_rule is co1 co2 + | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 + -- Given: + -- co1 = /\ tv1 : eta1. r1 + -- co2 = /\ tv2 : eta2. r2 + -- Wanted: + -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ + mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 + +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + where + push_trans cv1 eta1 r1 cv2 eta2 r2 + -- Given: + -- co1 = /\ cv1 : eta1. r1 + -- co2 = /\ cv2 : eta2. r2 + -- Wanted: + -- n1 = nth 2 eta1 + -- n2 = nth 3 eta1 + -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) + = fireTransRule "EtaAllTy_co" co1 co2 $ + mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` cv1 + role = coVarRole cv1 + eta1' = downgradeRole role Nominal eta1 + n1 = mkNthCo role 2 eta1' + n2 = mkNthCo role 3 eta1' + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` n2]) + r2 + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- See Note [Why call checkAxInstCo during optimisation] + -- TrPushSymAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , True <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst + + -- TrPushAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , False <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxR" co1 co2 newAxInst + + -- TrPushSymAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , True <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst + + -- TrPushAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , False <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxL" co1 co2 newAxInst + + -- TrPushAxSym/TrPushSymAx + | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe + , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe + , con1 == con2 + , ind1 == ind2 + , sym1 == not sym2 + , let branch = coAxiomNthBranch con1 ind1 + qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch + lhs = coAxNthLHS con1 ind1 + rhs = coAxBranchRHS branch + pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if sym2 + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + where + co1_is_axiom_maybe = isAxiom_maybe co1 + co2_is_axiom_maybe = isAxiom_maybe co2 + role = coercionRole co1 -- should be the same as coercionRole co2! + +opt_trans_rule _ co1 co2 -- Identity rule + | let ty1 = coercionLKind co1 + r = coercionRole co1 + ty2 = coercionRKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + mkReflCo r ty2 + +opt_trans_rule _ _ _ = Nothing + +-- See Note [EtaAppCo] +opt_trans_rule_app :: InScopeSet + -> Coercion -- original left-hand coercion (printing only) + -> Coercion -- original right-hand coercion (printing only) + -> Coercion -- left-hand coercion "function" + -> [Coercion] -- left-hand coercion "args" + -> Coercion -- right-hand coercion "function" + -> [Coercion] -- right-hand coercion "args" + -> Maybe Coercion +opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs + | AppCo co1aa co1ab <- co1a + , Just (co2aa, co2ab) <- etaAppCo_maybe co2a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | AppCo co2aa co2ab <- co2a + , Just (co1aa, co1ab) <- etaAppCo_maybe co1a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | otherwise + = ASSERT( co1bs `equalLength` co2bs ) + fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ + let rt1a = coercionRKind co1a + + lt2a = coercionLKind co2a + rt2a = coercionRole co2a + + rt1bs = map coercionRKind co1bs + lt2bs = map coercionLKind co2bs + rt2bs = map coercionRole co2bs + + kcoa = mkKindCo $ buildCoercion lt2a rt1a + kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs + + co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a + co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs + co2bs'' = zipWith mkTransCo co2bs' co2bs + in + mkAppCos (opt_trans is co1a co2a') + (zipWith (opt_trans is) co1bs co2bs'') + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = Just res + +{- +Note [Conflict checking with AxiomInstCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } + +We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ +False) and that all is OK. But, all is not OK: we want to use the first branch +of the axiom in this case, not the second. The problem is that the parameters +of the first branch can unify with the supplied coercions, thus meaning that +the first branch should be taken. See also Note [Apartness] in +types/FamInstEnv.hs. + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ False + +which is bogus! This is because the type system isn't smart enough to know +that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type +families. At the time of writing, I (Richard Eisenberg) couldn't think of +a way of detecting this any more efficient than just building the optimised +coercion and checking. + +Note [EtaAppCo] +~~~~~~~~~~~~~~~ +Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd +like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that +the resultant coercions might not be well kinded. Here is an example (things +labeled with x don't matter in this example): + + k1 :: Type + k2 :: Type + + a :: k1 -> Type + b :: k1 + + h :: k1 ~ k2 + + co1a :: x1 ~ (a |> (h -> ) + co1b :: x2 ~ (b |> h) + + co2a :: a ~ x3 + co2b :: b ~ x4 + +First, convince yourself of the following: + + co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) + co2a co2b :: a b ~ x3 x4 + + (a |> (h -> )) (b |> h) `eqType` a b + +That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep, +where we ignore coercions in types as long as two types' kinds are the same. +In our case, we meet this last condition, because + + (a |> (h -> )) (b |> h) :: Type + and + a b :: Type + +So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the +suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the +kinds don't match up. + +The solution here is to twiddle the kinds in the output coercions. First, we +need to find coercions + + ak :: kind(a |> (h -> )) ~ kind(a) + bk :: kind(b |> h) ~ kind(b) + +This can be done with mkKindCo and buildCoercion. The latter assumes two +types are identical modulo casts and builds a coercion between them. + +Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the +output coercions. These are well-kinded. + +Also, note that all of this is done after accumulated any nested AppCo +parameters. This step is to avoid quadratic behavior in calling coercionKind. + +The problem described here was first found in dependent/should_compile/dynamic-paper. + +-} + +-- | Check to make sure that an AxInstCo is internally consistent. +-- Returns the conflicting branch, if it exists +-- See Note [Conflict checking with AxiomInstCo] +checkAxInstCo :: Coercion -> Maybe CoAxBranch +-- defined here to avoid dependencies in GHC.Core.Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkAxInstCo (AxiomInstCo ax ind cos) + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map coercionLKind cos) + co_args = map stripCoercionTy cotys + subst = zipTvSubst tvs tys `composeTCvSubst` + zipCvSubst cvs co_args + target = Type.substTys subst (coAxBranchLHS branch) + in_scope = mkInScopeSet $ + unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + flattened_target = flattenTys in_scope target in + check_no_conflict flattened_target incomps + where + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in GHC.Core.FamInstEnv + | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b +checkAxInstCo _ = Nothing + + +----------- +wrapSym :: SymFlag -> Coercion -> Coercion +wrapSym sym co | sym = mkSymCo co + | otherwise = co + +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r + +----------- +isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) +isAxiom_maybe (SymCo co) + | Just (sym, con, ind, cos) <- isAxiom_maybe co + = Just (not sym, con, ind, cos) +isAxiom_maybe (AxiomInstCo con ind cos) + = Just (False, con, ind, cos) +isAxiom_maybe _ = Nothing + +matchAxiom :: Bool -- True = match LHS, False = match RHS + -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] +matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co + | CoAxBranch { cab_tvs = qtvs + , cab_cvs = [] -- can't infer these, so fail if there are any + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , Just subst <- liftCoMatch (mkVarSet qtvs) + (if sym then (mkTyConApp tc lhs) else rhs) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + x1 = coercionRKind co1 + x2 = coercionLKind co2 + +------------- +{- +etaForAllCo +~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h1)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) + eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) +-} +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) +etaForAllCo_ty_maybe co + | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 + , isForAllTy_ty ty2 + , let kind_co = mkNthCo Nominal 0 co + = Just ( tv1, kind_co + , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) + + | otherwise + = Nothing + +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall cv:kind_co. co) +etaForAllCo_co_maybe co + | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (cv1, _) <- splitForAllTy_co_maybe ty1 + , isForAllTy_co ty2 + = let kind_co = mkNthCo Nominal 0 co + r = coVarRole cv1 + l_co = mkCoVarCo cv1 + kind_co' = downgradeRole r Nominal kind_co + r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` + l_co `mkTransCo` + (mkNthCo r 3 kind_co') + in Just ( cv1, kind_co + , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) + + | otherwise + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = ASSERT( tc == tc2 ) Just cos2 + +etaTyConAppCo_maybe tc co + | not (mustBeSaturated tc) + , (Pair ty1 ty2, r) <- coercionKindRole co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep + , let n = length tys1 + , tys2 `lengthIs` n -- This can fail in an erroneous program + -- E.g. T a ~# T a b + -- #14607 + = ASSERT( tc == tc1 ) + Just (decomposeCo n co (tyConRolesX r tc1)) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + +-} + +optForAllCoBndr :: LiftingContext -> Bool + -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) +optForAllCoBndr env sym + = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/ConLike.hs @@ -0,0 +1,196 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[ConLike]{@ConLike@: Constructor-like things} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.ConLike ( + ConLike(..) + , conLikeArity + , conLikeFieldLabels + , conLikeInstOrigArgTys + , conLikeExTyCoVars + , conLikeName + , conLikeStupidTheta + , conLikeWrapId_maybe + , conLikeImplBangs + , conLikeFullSig + , conLikeResTy + , conLikeFieldType + , conLikesWithFields + , conLikeIsInfix + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.DataCon +import GHC.Core.PatSyn +import Outputable +import GHC.Types.Unique +import Util +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Core.TyCo.Rep (Type, ThetaType) +import GHC.Types.Var +import GHC.Core.Type(mkTyConApp) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection{Constructor-like things} +* * +************************************************************************ +-} + +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq ConLike where + (==) = eqConLike + +eqConLike :: ConLike -> ConLike -> Bool +eqConLike x y = getUnique x == getUnique y + +-- There used to be an Ord ConLike instance here that used Unique for ordering. +-- It was intentionally removed to prevent determinism problems. +-- See Note [Unique Determinism] in GHC.Types.Unique. + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" + +-- | Number of arguments +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn + +-- | Names of fields used for selectors +conLikeFieldLabels :: ConLike -> [FieldLabel] +conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con +conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn + +-- | Returns just the instantiated /value/ argument types of a 'ConLike', +-- (excluding dictionary args) +conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] +conLikeInstOrigArgTys (RealDataCon data_con) tys = + dataConInstOrigArgTys data_con tys +conLikeInstOrigArgTys (PatSynCon pat_syn) tys = + patSynInstArgTys pat_syn tys + +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 + +conLikeName :: ConLike -> Name +conLikeName (RealDataCon data_con) = dataConName data_con +conLikeName (PatSynCon pat_syn) = patSynName pat_syn + +-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- It is empty for `PatSynCon` as they do not allow such contexts. +conLikeStupidTheta :: ConLike -> ThetaType +conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con +conLikeStupidTheta (PatSynCon {}) = [] + +-- | Returns the `Id` of the wrapper. This is also known as the builder in +-- some contexts. The value is Nothing only in the case of unidirectional +-- pattern synonyms. +conLikeWrapId_maybe :: ConLike -> Maybe Id +conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con +conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn + +-- | Returns the strictness information for each constructor +conLikeImplBangs :: ConLike -> [HsImplBang] +conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con +conLikeImplBangs (PatSynCon pat_syn) = + replicate (patSynArity pat_syn) HsLazy + +-- | Returns the type of the whole pattern +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +-- | The \"full signature\" of the 'ConLike' returns, in order: +-- +-- 1) The universally quantified type variables +-- +-- 2) The existentially quantified type/coercion variables +-- +-- 3) The equality specification +-- +-- 4) The provided theta (the constraints provided by a match) +-- +-- 5) The required theta (the constraints required for a match) +-- +-- 6) The original argument types (i.e. before +-- any change of the representation of the type) +-- +-- 7) The original result type +conLikeFullSig :: ConLike + -> ([TyVar], [TyCoVar], [EqSpec] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in GHC.Core.DataCon + , ThetaType, ThetaType, [Type], Type) +conLikeFullSig (RealDataCon con) = + let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con + -- Required theta is empty as normal data cons require no additional + -- constraints for a match + in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) +conLikeFullSig (PatSynCon pat_syn) = + let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn + -- eqSpec is empty + in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) + +-- | Extract the type for any given labelled field of the 'ConLike' +conLikeFieldType :: ConLike -> FieldLabelString -> Type +conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label +conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label + + +-- | The ConLikes that have *all* the given fields +conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] +conLikesWithFields con_likes lbls = filter has_flds con_likes + where has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) + +conLikeIsInfix :: ConLike -> Bool +conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc +conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/compiler/GHC/Core/ConLike.hs-boot b/compiler/GHC/Core/ConLike.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/ConLike.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.ConLike where +import {-# SOURCE #-} GHC.Core.DataCon (DataCon) +import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn) +import GHC.Types.Name ( Name ) + +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +conLikeName :: ConLike -> Name diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/DataCon.hs @@ -0,0 +1,1468 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[DataCon]{@DataCon@: Data Constructors} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module GHC.Core.DataCon ( + -- * Main data types + DataCon, DataConRep(..), + SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), HsImplBang(..), + StrictnessMark(..), + ConTag, + + -- ** Equality specs + EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, + eqSpecPair, eqSpecPreds, + substEqSpec, filterEqSpec, + + -- ** Field labels + FieldLbl(..), FieldLabel, FieldLabelString, + + -- ** Type construction + mkDataCon, fIRST_TAG, + + -- ** Type deconstruction + dataConRepType, dataConInstSig, dataConFullSig, + dataConName, dataConIdentity, dataConTag, dataConTagZ, + dataConTyCon, dataConOrigTyCon, + dataConUserType, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConUserTyVars, dataConUserTyVarBinders, + dataConEqSpec, dataConTheta, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, + dataConSrcBangs, + dataConSourceArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, + dataConRepStrictness, dataConImplBangs, dataConBoxer, + + splitDataProductType_maybe, + + -- ** Predicates on DataCons + isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, + isUnboxedSumCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, + dataConUserTyVarsArePermuted, + isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, + specialPromotedDc, + + -- ** Promotion related functions + promoteDataCon + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) +import GHC.Core.Type as Type +import GHC.Core.Coercion +import GHC.Core.Unify +import GHC.Core.TyCon +import GHC.Types.FieldLabel +import GHC.Core.Class +import GHC.Types.Name +import PrelNames +import GHC.Core.Predicate +import GHC.Types.Var +import Outputable +import Util +import GHC.Types.Basic +import FastString +import GHC.Types.Module +import Binary +import GHC.Types.Unique.Set +import GHC.Types.Unique( mkAlphaTyVarUnique ) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Data as Data +import Data.Char +import Data.List( find ) + +{- +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker + +* The worker is very like a primop, in that it has no binding. + +* For a *data* type, the worker *is* the data constructor; + it has no unfolding + +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \\(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int + +The "wrapper Id", \$WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* The wrapper Id isn't generated for a data type if there is + nothing for the wrapper to do. That is, if its defn would be + \$wC = C + +Note [Data constructor workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Algebraic data types + - Always have a worker, with no unfolding + - May or may not have a wrapper; see Note [The need for a wrapper] + +* Newtypes + - Always have a worker, which has a compulsory unfolding (just a cast) + - May or may not have a wrapper; see Note [The need for a wrapper] + +* INVARIANT: the dictionary constructor for a class + never has a wrapper. + +* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + +* The wrapper (if it exists) takes dcOrigArgTys as its arguments + The worker takes dataConRepArgTys as its arguments + If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys + +* The 'NoDataConRep' case of DataConRep is important. Not only is it + efficient, but it also ensures that the wrapper is replaced by the + worker (because it *is* the worker) even when there are no + args. E.g. in + f (:) x + the (:) *is* the worker. This is really important in rule matching, + (We could match on the wrappers, but that makes it less likely that + rules will match when we bring bits of unfoldings together.) + +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why might the wrapper have anything to do? The full story is +in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep. + +* Unboxing strict fields (with -funbox-strict-fields) + data T = MkT !(Int,Int) + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y + Notice that the worker has two fields where the wapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + MkT :: forall a b. (a=[b]) => b -> T a + + The wrapper has the programmer-specified type: + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x + The third argument is a coercion + [a] :: [a]~[a] + +* Data family instances may do a cast on the result + +* Type variables may be permuted; see MkId + Note [Data con wrappers and GADT syntax] + + +Note [The stupid context] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +and that makes the constructors have a context too +(notice that T2's context is "thinned"): + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +It's a flaw in the language. + + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. + + [May 2003: actually I think this decision could easily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ +-} + +-- | A data constructor +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's + + -- Running example: + -- + -- *** As declared by the user + -- data T a b c where + -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c + + -- *** As represented internally + -- data T a b c where + -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) + -- => x -> y -> T a b c + -- + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcUnivTyVars = [a,b,c] + -- dcExTyCoVars = [x,y] + -- dcUserTyVarBinders = [c,y,x,b] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: + -- + -- data H a where + -- MkH :: b -> H b + -- + -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH + -- will be [b]. + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no coercions, nothing. + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] + -- NB 1: newtypes always have a vanilla data con + -- NB 2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + -- The declaration format is held in the TyCon (algTcGadtSyntax) + + -- Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + -- INVARIANT: result type of data con worker is exactly (T a b c) + -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with + -- the tyConTyVars of the parent TyCon + dcUnivTyVars :: [TyVar], + + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why tycovars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], + + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames + -- Reason: less confusing, and easier to generate Iface syntax + + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set + -- of tyvars (*not* covars) of dcExTyCoVars unioned with the + -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec + -- See Note [DataCon user type variable binders] + dcUserTyVarBinders :: [TyVarBinder], + + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). + + -- This field allows us to move conveniently between the two ways + -- of representing a GADT constructor's type: + -- MkT :: forall a b. (a ~ [b]) => b -> T a + -- MkT :: forall b. b -> T [b] + -- Each equality is of the form (a ~ ty), where 'a' is one of + -- the universally quantified type variables + + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) + -- In GADT form, this is *exactly* what the programmer writes, even if + -- the context constrains only universally quantified variables + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec + + dcStupidTheta :: ThetaType, -- The context of the data type declaration + -- data Eq a => T a = ... + -- or, rather, a "thinned" version thereof + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor + -- + -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars + -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- Indeed, [as of March 02] they are no longer in the type of + -- the wrapper Id, because that makes it harder to use the wrap-id + -- to rebuild values after record selection or in generics. + + dcOrigArgTys :: [Type], -- Original argument types + -- (before unboxing and flattening of strict fields) + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 + + -- Now the strictness annotations and field labels of the constructor + dcSrcBangs :: [HsSrcBang], + -- See Note [Bangs on data constructor arguments] + -- + -- The [HsSrcBang] as written by the programmer. + -- + -- Matches 1-1 with dcOrigArgTys + -- Hence length = dataConSourceArity dataCon + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the dcOrigArgTys; + -- length = 0 (if not a record) or dataConSourceArity. + + -- The curried worker function that corresponds to the constructor: + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + dcWorkId :: Id, + + -- Constructor representation + dcRep :: DataConRep, + + -- Cached; see Note [DataCon arities] + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) + -- INVARIANT: dcSourceArity == length dcOrigArgTys + dcRepArity :: Arity, + dcSourceArity :: Arity, + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + + dcRepType :: Type, -- Type of the constructor + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a + -- (this is *not* of the constructor wrapper Id: + -- see Note [Data con representation] below) + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t + -- and use that to check the pattern. Mind you, this is really only + -- used in GHC.Core.Lint. + + + dcInfix :: Bool, -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + + dcPromoted :: TyCon -- The promoted TyCon + -- See Note [Promoted data constructors] in GHC.Core.TyCon + } + + +{- Note [TyVarBinders in DataCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the TyVarBinders in a DataCon and PatSyn: + + * Each argument flag is Inferred or Specified. + None are Required. (A DataCon is a term-level function; see + Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.) + +Why do we need the TyVarBinders, rather than just the TyVars? So that +we can construct the right type for the DataCon with its foralls +attributed the correct visibility. That in turn governs whether you +can use visible type application at a call of the data constructor. + +See also [DataCon user type variable binders] for an extended discussion on the +order in which TyVarBinders appear in a DataCon. + +Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) + => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b~(c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + + Function call 'dataConKindEqSpec' returns [k'~k] + +Note [DataCon arities] +~~~~~~~~~~~~~~~~~~~~~~ +dcSourceArity does not take constraints into account, +but dcRepArity does. For example: + MkT :: Ord a => a -> T a + dcSourceArity = 1 + dcRepArity = 2 + +Note [DataCon user type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In System FC, data constructor type signatures always quantify over all of +their universal type variables, followed by their existential type variables. +Normally, this isn't a problem, as most datatypes naturally quantify their type +variables in this order anyway. For example: + + data T a b = forall c. MkT b c + +Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, +where k, a, and b are universal and c is existential. (The inferred variable k +isn't available for TypeApplications, hence why it's in braces.) This is a +perfectly reasonable order to use, as the syntax of H98-style datatypes +(+ ExistentialQuantification) suggests it. + +Things become more complicated when GADT syntax enters the picture. Consider +this example: + + data X a where + MkX :: forall b a. b -> Proxy a -> X a + +If we adopt the earlier approach of quantifying all the universal variables +followed by all the existential ones, GHC would come up with this type +signature for MkX: + + MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a + +But this is not what we want at all! After all, if a user were to use +TypeApplications on MkX, they would expect to instantiate `b` before `a`, +as that's the order in which they were written in the `forall`. (See #11721.) +Instead, we'd like GHC to come up with this type signature: + + MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a + +In fact, even if we left off the explicit forall: + + data X a where + MkX :: b -> Proxy a -> X a + +Then a user should still expect `b` to be quantified before `a`, since +according to the rules of TypeApplications, in the absence of `forall` GHC +performs a stable topological sort on the type variables in the user-written +type signature, which would place `b` before `a`. + +But as noted above, enacting this behavior is not entirely trivial, as System +FC demands the variables go in universal-then-existential order under the hood. +Our solution is thus to equip DataCon with two different sets of type +variables: + +* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential + type/coercion variables, respectively. Their order is irrelevant for the + purposes of TypeApplications, and as a consequence, they do not come equipped + with visibilities (that is, they are TyVars/TyCoVars instead of + TyCoVarBinders). +* dcUserTyVarBinders, for the type variables binders in the order in which they + originally arose in the user-written type signature. Their order *does* matter + for TypeApplications, so they are full TyVarBinders, complete with + visibilities. + +This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders +consists precisely of: + +* The set of tyvars in dcUnivTyVars whose type variables do not appear in + dcEqSpec, unioned with: +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". + +dcUserTyVarBinders, as the name suggests, is the one that users will see most of +the time. It's used when computing the type signature of a data constructor (see +dataConUserType), and as a result, it's what matters from a TypeApplications +perspective. +-} + +-- | Data Constructor Representation +-- See Note [Data constructor workers and wrappers] +data DataConRep + = -- NoDataConRep means that the data con has no wrapper + NoDataConRep + + -- DCR means that the data con has a wrapper + | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, + -- and constructs the representation + + , dcr_boxer :: DataConBoxer + + , dcr_arg_tys :: [Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args + + , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys + -- See also Note [Data-con worker strictness] in GHC.Types.Id.Make + + , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + } + +------------------------- + +-- | Haskell Source Bang +-- +-- Bangs on data constructor arguments as the user wrote them in the +-- source code. +-- +-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and +-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we +-- emit a warning (in checkValidDataCon) and treat it like +-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ +data HsSrcBang = + HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.Basic + SrcUnpackedness + SrcStrictness + deriving Data.Data + +-- | Haskell Implementation Bang +-- +-- Bangs of data constructor arguments as generated by the compiler +-- after consulting HsSrcBang, flags, etc. +data HsImplBang + = HsLazy -- ^ Lazy field, or one with an unlifted type + | HsStrict -- ^ Strict but not unpacked field + | HsUnpack (Maybe Coercion) + -- ^ Strict and unpacked field + -- co :: arg-ty ~ product-ty HsBang + deriving Data.Data + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data.Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data.Data) + + + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict + +-- | An 'EqSpec' is a tyvar/type pair representing an equality made in +-- rejigging a GADT constructor +data EqSpec = EqSpec TyVar + Type + +-- | Make a non-dependent 'EqSpec' +mkEqSpec :: TyVar -> Type -> EqSpec +mkEqSpec tv ty = EqSpec tv ty + +eqSpecTyVar :: EqSpec -> TyVar +eqSpecTyVar (EqSpec tv _) = tv + +eqSpecType :: EqSpec -> Type +eqSpecType (EqSpec _ ty) = ty + +eqSpecPair :: EqSpec -> (TyVar, Type) +eqSpecPair (EqSpec tv ty) = (tv, ty) + +eqSpecPreds :: [EqSpec] -> ThetaType +eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty + | EqSpec tv ty <- spec ] + +-- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec +-- is mapped in the substitution, it is mapped to a type variable, not +-- a full type. +substEqSpec :: TCvSubst -> EqSpec -> EqSpec +substEqSpec subst (EqSpec tv ty) + = EqSpec tv' (substTy subst ty) + where + tv' = getTyVar "substEqSpec" (substTyVar subst tv) + +-- | Filter out any 'TyVar's mentioned in an 'EqSpec'. +filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] +filterEqSpec eq_spec + = filter not_in_eq_spec + where + not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec + +instance Outputable EqSpec where + ppr (EqSpec tv ty) = ppr (tv, ty) + +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int {-# UNPACK #-} !Int Bool + +When compiling the module, GHC will decide how to represent +MkT, depending on the optimisation level, and settings of +flags like -funbox-small-strict-fields. + +Terminology: + * HsSrcBang: What the user wrote + Constructors: HsSrcBang + + * HsImplBang: What GHC decided + Constructors: HsLazy, HsStrict, HsUnpack + +* If T was defined in this module, MkT's dcSrcBangs field + records the [HsSrcBang] of what the user wrote; in the example + [ HsSrcBang _ NoSrcUnpack SrcStrict + , HsSrcBang _ SrcUnpack SrcStrict + , HsSrcBang _ NoSrcUnpack NoSrcStrictness] + +* However, if T was defined in an imported module, the importing module + must follow the decisions made in the original module, regardless of + the flag settings in the importing module. + Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make + +* The dcr_bangs field of the dcRep field records the [HsImplBang] + If T was defined in this module, Without -O the dcr_bangs might be + [HsStrict, HsStrict, HsLazy] + With -O it might be + [HsStrict, HsUnpack _, HsLazy] + With -funbox-small-strict-fields it might be + [HsUnpack, HsUnpack _, HsLazy] + With -XStrictData it might be + [HsStrict, HsUnpack _, HsStrict] + +Note [Data con representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The dcRepType field contains the type of the representation of a constructor +This may differ from the type of the constructor *Id* (built +by MkId.mkDataConId) for two reasons: + a) the constructor Id may be overloaded, but the dictionary isn't stored + e.g. data Eq a => T a = MkT a a + + b) the constructor may store an unboxed version of a strict field. + +Here's an example illustrating both: + data Ord a => T a = MkT Int! a +Here + T :: Ord a => Int -> a -> T a +but the rep type is + Trep :: Int# -> a -> T a +Actually, the unboxed part isn't implemented yet! + + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" + +instance Outputable HsSrcBang where + ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark + +instance Outputable HsImplBang where + ppr HsLazy = text "Lazy" + ppr (HsUnpack Nothing) = text "Unpacked" + ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) + ppr HsStrict = text "StrictNotUnpacked" + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable StrictnessMark where + ppr MarkedStrict = text "!" + ppr NotMarkedStrict = empty + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +-- | Compare strictness annotations +eqHsBang :: HsImplBang -> HsImplBang -> Bool +eqHsBang HsLazy HsLazy = True +eqHsBang HsStrict HsStrict = True +eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True +eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) + = eqType (coercionType c1) (coercionType c2) +eqHsBang _ _ = False + +isBanged :: HsImplBang -> Bool +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True +isBanged HsLazy = False + +isSrcStrict :: SrcStrictness -> Bool +isSrcStrict SrcStrict = True +isSrcStrict _ = False + +isSrcUnpacked :: SrcUnpackedness -> Bool +isSrcUnpacked SrcUnpack = True +isSrcUnpacked _ = False + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict + +{- ********************************************************************* +* * +\subsection{Construction} +* * +********************************************************************* -} + +-- | Build a new data constructor +mkDataCon :: Name + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ + -> [EqSpec] -- ^ GADT equalities + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper + -> [KnotTied Type] -- ^ Original argument types + -> KnotTied Type -- ^ Original result type + -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' + -> KnotTied TyCon -- ^ Representation type constructor + -> ConTag -- ^ Constructor tag + -> ThetaType -- ^ The "stupid theta", context of the data + -- declaration e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix prom_info + arg_stricts -- Must match orig_arg_tys 1-1 + fields + univ_tvs ex_tvs user_tvbs + eq_spec theta + orig_arg_tys orig_res_ty rep_info rep_tycon tag + stupid_theta work_id rep +-- Warning: mkDataCon is not a good place to check certain invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that assertions here +-- are a little dodgy. + + = con + where + is_vanilla = null ex_tvs && null eq_spec && null theta + + con = MkData {dcName = name, dcUnique = nameUnique name, + dcVanilla = is_vanilla, dcInfix = declared_infix, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs, + dcUserTyVarBinders = user_tvbs, + dcEqSpec = eq_spec, + dcOtherTheta = theta, + dcStupidTheta = stupid_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, + dcSrcBangs = arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = rep_ty, + dcWorkId = work_id, + dcRep = rep, + dcSourceArity = length orig_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, + dcPromoted = promoted } + + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + + rep_arg_tys = dataConRepArgTys con + + rep_ty = + case rep of + -- If the DataCon has no wrapper, then the worker's type *is* the + -- user-facing type, so we can simply use dataConUserType. + NoDataConRep -> dataConUserType con + -- If the DataCon has a wrapper, then the worker's type is never seen + -- by the user. The visibilities we pick do not matter here. + DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + mkVisFunTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + + -- See Note [Promoted data constructors] in GHC.Core.TyCon + prom_tv_bndrs = [ mkNamedTyConBinder vis tv + | Bndr tv vis <- user_tvbs ] + + fresh_names = freshNames (map getName user_tvbs) + -- fresh_names: make sure that the "anonymous" tyvars don't + -- clash in name or unique with the universal/existential ones. + -- Tiresome! And unnecessary because these tyvars are never looked at + prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) + {- Invisible -} | (n,t) <- fresh_names `zip` theta ] + prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) + {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] + prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs + prom_res_kind = orig_res_ty + promoted = mkPromotedDataCon con name prom_info prom_bndrs + prom_res_kind roles rep_info + + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) (theta ++ orig_arg_tys) + +freshNames :: [Name] -> [Name] +-- Make an infinite list of Names whose Uniques and OccNames +-- differ from those in the 'avoid' list +freshNames avoids + = [ mkSystemName uniq occ + | n <- [0..] + , let uniq = mkAlphaTyVarUnique n + occ = mkTyVarOccFS (mkFastString ('x' : show n)) + + , not (uniq `elementOfUniqSet` avoid_uniqs) + , not (occ `elemOccSet` avoid_occs) ] + + where + avoid_uniqs :: UniqSet Unique + avoid_uniqs = mkUniqSet (map getUnique avoids) + + avoid_occs :: OccSet + avoid_occs = mkOccSet (map getOccName avoids) + +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification +dataConName :: DataCon -> Name +dataConName = dcName + +-- | The tag used for ordering 'DataCon's +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +-- | The type constructor that we are building via this data constructor +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +-- | Should the 'DataCon' be presented infix? +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +-- | The universally-quantified type variables of the constructor +dataConUnivTyVars :: DataCon -> [TyVar] +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs + +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs + +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) + = univ_tvs ++ ex_tvs + +-- See Note [DataCon user type variable binders] +-- | The type variables of the constructor, in the order the user wrote them +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs + +-- See Note [DataCon user type variable binders] +-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the +-- user wrote them +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders = dcUserTyVarBinders + +-- | Equalities derived from the result type of the data constructor, as written +-- by the programmer in any GADT declaration. This includes *all* GADT-like +-- equalities, including those written in by hand by the programmer. +dataConEqSpec :: DataCon -> [EqSpec] +dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = dataConKindEqSpec con + ++ eq_spec ++ + [ spec -- heterogeneous equality + | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` heqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] ++ + [ spec -- homogeneous equality + | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` eqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] + +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + tv = getTyVar "dataConKindEqSpec" ty1 + ] + +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. +dataConTheta :: DataCon -> ThetaType +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' +dataConWorkId :: DataCon -> Id +dataConWorkId dc = dcWorkId dc + +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcRep dc of + NoDataConRep -> Nothing + DCR { dcr_wrap_id = wrap_id } -> Just wrap_id + +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') +dataConWrapId :: DataCon -> Id +dataConWrapId dc = case dcRep dc of + NoDataConRep-> dcWorkId dc -- worker=wrapper + DCR { dcr_wrap_id = wrap_id } -> wrap_id + +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' +dataConImplicitTyThings :: DataCon -> [TyThing] +dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) + = [AnId work] ++ wrap_ids + where + wrap_ids = case rep of + NoDataConRep -> [] + DCR { dcr_wrap_id = wrap } -> [AnId wrap] + +-- | The labels for the fields of this particular 'DataCon' +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +-- | Extract the type for any given labelled field of the 'DataCon' +dataConFieldType :: DataCon -> FieldLabelString -> Type +dataConFieldType con label = case dataConFieldType_maybe con label of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | Extract the label and type for any given labelled field of the +-- 'DataCon', or return 'Nothing' if the field does not belong to it +dataConFieldType_maybe :: DataCon -> FieldLabelString + -> Maybe (FieldLabel, Type) +dataConFieldType_maybe con label + = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) + +-- | Strictness/unpack annotations, from user; or, for imported +-- DataCons, from the interface file +-- The list is in one-to-one correspondence with the arity of the 'DataCon' + +dataConSrcBangs :: DataCon -> [HsSrcBang] +dataConSrcBangs = dcSrcBangs + +-- | Source-level arity of the data constructor +dataConSourceArity :: DataCon -> Arity +dataConSourceArity (MkData { dcSourceArity = arity }) = arity + +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries +dataConRepArity :: DataCon -> Arity +dataConRepArity (MkData { dcRepArity = arity }) = arity + +-- | Return whether there are any argument types for this 'DataCon's original source type +-- See Note [DataCon arities] +isNullarySrcDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = dataConSourceArity dc == 0 + +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +-- See Note [DataCon arities] +isNullaryRepDataCon :: DataCon -> Bool +isNullaryRepDataCon dc = dataConRepArity dc == 0 + +dataConRepStrictness :: DataCon -> [StrictnessMark] +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) +dataConRepStrictness dc = case dcRep dc of + NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] + DCR { dcr_stricts = strs } -> strs + +dataConImplBangs :: DataCon -> [HsImplBang] +-- The implementation decisions about the strictness/unpack of each +-- source program argument to the data constructor +dataConImplBangs dc + = case dcRep dc of + NoDataConRep -> replicate (dcSourceArity dc) HsLazy + DCR { dcr_bangs = bangs } -> bangs + +dataConBoxer :: DataCon -> Maybe DataConBoxer +dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer +dataConBoxer _ = Nothing + +dataConInstSig + :: DataCon + -> [Type] -- Instantiate the *universal* tyvars with these types + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys +-- ^ Instantiate the universal tyvars of a data con, +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) + univ_tys + = ( ex_tvs' + , substTheta subst (dataConTheta con) + , substTys subst arg_tys) + where + univ_subst = zipTvSubst univ_tvs univ_tys + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs + + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyCoVars' +-- +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). +-- +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) +-- +-- 6) The original result type of the 'DataCon' +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +dataConUserType :: DataCon -> Type +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- +-- The type variables are quantified in the order that the user wrote them. +-- See @Note [DataCon user type variable binders]@. +-- +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. +dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = mkForAllTys user_tvbs $ + mkInvisFunTys theta $ + mkVisFunTys arg_tys $ + res_ty + +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Type] +dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2( null ex_tvs, ppr dc ) + map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just +-- the value args +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTy subst) arg_tys + where + tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys + +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables +dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +-- | Returns the arg types of the worker, including *all* non-dependent +-- evidence, after any flattening has been done and without substituting for +-- any type variables +dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec + , dcOtherTheta = theta + , dcOrigArgTys = orig_arg_tys }) + = case rep of + NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys + DCR { dcr_arg_tys = arg_tys } -> arg_tys + +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> ByteString +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat + [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) + , BSB.int8 $ fromIntegral (ord ':') + , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) + , BSB.int8 $ fromIntegral (ord '.') + , BSB.byteString $ bytesFS (occNameFS (nameOccName name)) + ] + where name = dataConName dc + mod = ASSERT( isExternalName name ) nameModule name + +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc + +isUnboxedTupleCon :: DataCon -> Bool +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc + +isUnboxedSumCon :: DataCon -> Bool +isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc + +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc + +-- | Should this DataCon be allowed in a type even without -XDataKinds? +-- Currently, only Lifted & Unlifted +specialPromotedDc :: DataCon -> Bool +specialPromotedDc = isKindTyCon . dataConTyCon + +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" + +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the dcRepTyCon for the data con +dataConCannotMatch tys con + -- See (U6) in Note [Implementing unsafeCoerce] + -- in base:Unsafe.Coerce + | dataConName con == unsafeReflDataConName + = False + | null inst_theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise = typesCantMatch (concatMap predEqs inst_theta) + where + (_, inst_theta, _) = dataConInstSig con tys + + -- TODO: could gather equalities from superclasses too + predEqs pred = case classifyPredType pred of + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + ClassPred eq args + | eq `hasKey` eqTyConKey + , [_, ty1, ty2] <- args -> [(ty1, ty2)] + | eq `hasKey` heqTyConKey + , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] + _ -> [] + +-- | Were the type variables of the data con written in a different order +-- than the regular order (universal tyvars followed by existential tyvars)? +-- +-- This is not a cheap test, so we minimize its use in GHC as much as possible. +-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in +-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- during a data constructor's lifetime. + +-- See Note [DataCon user type variable binders], as well as +-- Note [Data con wrappers and GADT syntax] for an explanation of what +-- mkDataConRep is doing with this function. +dataConUserTyVarsArePermuted :: DataCon -> Bool +dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec + , dcUserTyVarBinders = user_tvbs }) = + (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs + +{- +%************************************************************************ +%* * + Promoting of data types to the kind level +* * +************************************************************************ + +-} + +promoteDataCon :: DataCon -> TyCon +promoteDataCon (MkData { dcPromoted = tc }) = tc + +{- +************************************************************************ +* * +\subsection{Splitting products} +* * +************************************************************************ +-} + +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its /representation/ arg types + + -- Rejecting existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tycon + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing + diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -0,0 +1,34 @@ +module GHC.Core.DataCon where + +import GhcPrelude +import GHC.Types.Var( TyVar, TyCoVar, TyVarBinder ) +import GHC.Types.Name( Name, NamedThing ) +import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) +import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Types.Unique ( Uniquable ) +import Outputable ( Outputable, OutputableBndr ) +import GHC.Types.Basic (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType ) + +data DataCon +data DataConRep +data EqSpec + +dataConName :: DataCon -> Name +dataConTyCon :: DataCon -> TyCon +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConSourceArity :: DataCon -> Arity +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] +dataConStupidTheta :: DataCon -> ThetaType +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +isUnboxedSumCon :: DataCon -> Bool + +instance Eq DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -62,24 +62,24 @@ import GhcPrelude import GHC.Core -import Id -import IdInfo -import NameSet -import UniqSet -import Unique (Uniquable (..)) -import Name -import VarSet -import Var -import Type -import TyCoRep -import TyCoFVs -import TyCon -import CoAxiom -import FamInstEnv +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Set +import GHC.Types.Unique.Set +import GHC.Types.Unique (Uniquable (..)) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv import TysPrim( funTyConName ) import Maybes( orElse ) import Util -import BasicTypes( Activation ) +import GHC.Types.Basic( Activation ) import Outputable import FV diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -0,0 +1,1836 @@ +-- (c) The University of Glasgow 2006 +-- +-- FamInstEnv: Type checked family instance declarations + +{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections, + DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInsts, + mkImportedFamInst, + + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + extendFamInstEnv, extendFamInstEnvList, + famInstEnvElts, famInstEnvSize, familyInstances, + + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + mkNewTypeCoAxiom, + + FamInstMatch(..), + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, + + isDominatedBy, apartnessCheck, + + -- Injectivity + InjectivityCheckResult(..), + lookupFamInstEnvInjectivityConflicts, injectiveBranches, + + -- Normalisation + topNormaliseType, topNormaliseType_maybe, + normaliseType, normaliseTcApp, normaliseTcArgs, + reduceTyFamApp_maybe, + + -- Flattening + flattenTys + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Unify +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name +import GHC.Types.Unique.DFM +import Outputable +import Maybes +import GHC.Core.Map +import GHC.Types.Unique +import Util +import GHC.Types.Var +import GHC.Types.SrcLoc +import FastString +import Control.Monad +import Data.List( mapAccumL ) +import Data.Array( Array, assocs ) + +{- +************************************************************************ +* * + Type checked family instance heads +* * +************************************************************************ + +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family +-} + +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom + -- introduced by this family + -- instance + -- INVARIANT: apart from freshening (see below) + -- fi_tvs = cab_tvs of the (single) axiom branch + -- fi_cvs = cab_cvs ...ditto... + -- fi_tys = cab_lhs ...ditto... + -- fi_rhs = cab_rhs ...ditto... + + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in GHC.Core.InstEnv + , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match + , fi_cvs :: [CoVar] -- Template covars for full match + -- Like ClsInsts, these variables are always fresh + -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv + + , fi_tys :: [Type] -- The LHS type patterns + -- May be eta-reduced; see Note [Eta reduction for data families] + + , fi_rhs :: Type -- the RHS, with its freshened vars + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon + +{- +Note [Arity of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data family instances might legitimately be over- or under-saturated. + +Under-saturation has two potential causes: + U1) Eta reduction. See Note [Eta reduction for data families]. + U2) When the user has specified a return kind instead of written out patterns. + Example: + + data family Sing (a :: k) + data instance Sing :: Bool -> Type + + The data family tycon Sing has an arity of 2, the k and the a. But + the data instance has only one pattern, Bool (standing in for k). + This instance is equivalent to `data instance Sing (a :: Bool)`, but + without the last pattern, we have an under-saturated data family instance. + On its own, this example is not compelling enough to add support for + under-saturation, but U1 makes this feature more compelling. + +Over-saturation is also possible: + O1) If the data family's return kind is a type variable (see also #12369), + an instance might legitimately have more arguments than the family. + Example: + + data family Fix :: (Type -> k) -> k + data instance Fix f = MkFix1 (f (Fix f)) + data instance Fix f x = MkFix2 (f (Fix f x) x) + + In the first instance here, the k in the data family kind is chosen to + be Type. In the second, it's (Type -> Type). + + However, we require that any over-saturation is eta-reducible. That is, + we require that any extra patterns be bare unrepeated type variables; + see Note [Eta reduction for data families]. Accordingly, the FamInst + is never over-saturated. + +Why can we allow such flexibility for data families but not for type families? +Because data families can be decomposed -- that is, they are generative and +injective. A Type family is neither and so always must be applied to all its +arguments. +-} + +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom Unbranched +famInstAxiom = fi_axiom + +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) + +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs + +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance NamedThing FamInst where + getName = coAxiomName . fi_axiom + +instance Outputable FamInst where + ppr = pprFamInst + +pprFamInst :: FamInst -> SDoc +-- Prints the FamInst as a family instance declaration +-- NB: This function, FamInstEnv.pprFamInst, is used only for internal, +-- debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user +pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax + , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) + = hang (ppr_tc_sort <+> text "instance" + <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) + 2 (whenPprDebug debug_stuff) + where + ppr_tc_sort = case flavor of + SynFamilyInst -> text "type" + DataFamilyInst tycon + | isDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon + + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr tvs + , text "LHS:" <+> ppr tys + , text "RHS:" <+> ppr rhs ] + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) + +{- +Note [Lazy axiom match] +~~~~~~~~~~~~~~~~~~~~~~~ +It is Vitally Important that mkImportedFamInst is *lazy* in its axiom +parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime +later, mkImportedFamInst is called using that axiom. However, the axiom +may itself depend on entities which are not yet loaded as of the time +of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the +axiom, a dependency loop spontaneously appears and GHC hangs. The solution +is simply for mkImportedFamInst never, ever to look inside of the axiom +until everything else is good and ready to do so. We can assume that this +readiness has been achieved when some other code pulls on the axiom in the +FamInst. Thus, we pattern match on the axiom lazily (in the where clause, +not in the parameter list) and we assert the consistency of names there +also. +-} + +-- Make a family instance representation from the information found in an +-- interface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +mkImportedFamInst :: Name -- Name of the family + -> [Maybe Name] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_cvs = cvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor } + where + -- See Note [Lazy axiom match] + ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_cvs = cvs + , cab_rhs = rhs }) = coAxiomSingleBranch axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst + +{- +************************************************************************ +* * + FamInstEnv +* * +************************************************************************ + +Note [FamInstEnv] +~~~~~~~~~~~~~~~~~ +A FamInstEnv maps a family name to the list of known instances for that family. + +The same FamInstEnv includes both 'data family' and 'type family' instances. +Type families are reduced during type inference, but not data families; +the user explains when to use a data family instance by using constructors +and pattern matching. + +Nevertheless it is still useful to have data families in the FamInstEnv: + + - For finding overlaps and conflicts + + - For finding the representation type...see FamInstEnv.topNormaliseType + and its call site in GHC.Core.Op.Simplify + + - In standalone deriving instance Eq (T [Int]) we need to find the + representation type for T [Int] + +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two; +see Note [Eta reduction for data families] + +Note [FamInstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn FamInstEnvs into a list in some places that don't directly affect +the ABI. That happens in family consistency checks and when producing output +for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard +to tell what it affects without following a chain of functions. It's also +easy to accidentally make that nondeterminism affect the ABI. Furthermore +the envs should be relatively small, so it should be free to use deterministic +maps here. Testing with nofib and validate detected no difference between +UniqFM and UniqDFM. +See Note [Deterministic UniqFM]. +-} + +type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances + -- See Note [FamInstEnv] + -- See Note [FamInstEnv determinism] + +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +newtype FamilyInstEnv + = FamIE [FamInst] -- The instances for a particular family, in any order + +instance Outputable FamilyInstEnv where + ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) + +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) +emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = emptyUDFM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] + -- See Note [FamInstEnv determinism] + +famInstEnvSize :: FamInstEnv -> Int +famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 + -- It's OK to use nonDetFoldUDFM here since we're just computing the + -- size. + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get env = case lookupUDFM env fam of + Just (FamIE insts) -> insts + Nothing -> [] + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv inst_env + ins_item@(FamInst {fi_fam = cls_nm}) + = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) + where + add (FamIE items) _ = FamIE (ins_item:items) + +{- +************************************************************************ +* * + Compatibility +* * +************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Flattening].) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the +substitution induced by the match, other branches are surely apart. (See +Note [Apartness].) This is similar to what happens with class +instance selection, when we need to guarantee that there is only a match and +no unifiers. The exact algorithm is different here because the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). + +Note [Compatibility of eta-reduced axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In newtype instances of data families we eta-reduce the axioms, +See Note [Eta reduction for data families] in GHC.Core.FamInstEnv. This means that +we sometimes need to test compatibility of two axioms that were eta-reduced to +different degrees, e.g.: + + +data family D a b c +newtype instance D a Int c = DInt (Maybe a) + -- D a Int ~ Maybe + -- lhs = [a, Int] +newtype instance D Bool Int Char = DIntChar Float + -- D Bool Int Char ~ Float + -- lhs = [Bool, Int, Char] + +These are obviously incompatible. We could detect this by saturating +(eta-expanding) the shorter LHS with fresh tyvars until the lists are of +equal length, but instead we can just remove the tail of the longer list, as +those types will simply unify with the freshly introduced tyvars. + +By doing this, in case the LHS are unifiable, the yielded substitution won't +mention the tyvars that appear in the tail we dropped off, and we might try +to test equality RHSes of different kinds, but that's fine since this case +occurs only for data families, where the RHS is a unique tycon and the equality +fails anyway. +-} + +-- See Note [Compatibility] +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 + -- See Note [Compatibility of eta-reduced axioms] + in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of + SurelyApart -> True + Unifiable subst + | Type.substTyAddInScope subst rhs1 `eqType` + Type.substTyAddInScope subst rhs2 + -> True + _ -> False + +-- | Result of testing two type family equations for injectiviy. +data InjectivityCheckResult + = InjectivityAccepted + -- ^ Either RHSs are distinct or unification of RHSs leads to unification of + -- LHSs + | InjectivityUnified CoAxBranch CoAxBranch + -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for + -- closed type families where equation after unification might be + -- overlpapped (in which case it is OK if they don't unify). Constructor + -- stores axioms after unification. + +-- | Check whether two type family axioms don't violate injectivity annotation. +injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch + -> InjectivityCheckResult +injectiveBranches injectivity + ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + -- See Note [Verifying injectivity annotation], case 1. + = let getInjArgs = filterByList injectivity + in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + Nothing -> InjectivityAccepted + -- RHS are different, so equations are injective. + -- This is case 1A from Note [Verifying injectivity annotation] + Just subst -> -- RHS unify under a substitution + let lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. + then InjectivityAccepted + else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- payload of InjectivityUnified used only for check 1B2, only + -- for closed type families + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] +computeAxiomIncomps branches + = snd (mapAccumL go [] branches) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_brs cur_br + = (cur_br : prev_brs, new_br) + where + new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } + + mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] + mk_incomps prev_brs cur_br + = filter (not . compatibleBranches cur_br) prev_brs + +{- +************************************************************************ +* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in GHC.Core.Coercion.Axiom + + Also computeAxiomIncomps is too sophisticated for CoAxiom +* * +************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Like types and classes, we build axioms fully quantified over all +their variables, and tidy them when we build them. For example, +we print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See #7524. + +We could instead tidy when we print, but that makes it harder to get +things like injectivity errors to come out right. Danger of + Type family equation violates injectivity annotation. + Kind variable ‘k’ cannot be inferred from the right-hand side. + In the type family equation: + PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 + +Note [Always number wildcard types in CoAxBranch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from the DataFamilyInstanceLHS test case): + + data family Sing (a :: k) + data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +If we're not careful during tidying, then when this program is compiled with +-ddump-types, we'll get the following information: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + +It's misleading to have a wildcard type appearing on the RHS like +that. To avoid this issue, when building a CoAxiom (which is what eventually +gets printed above), we tidy all the variables in an env that already contains +'_'. Thus, any variable named '_' will be renamed, giving us the nicer output +here: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 + +Which is at least legal syntax. + +See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we +are tidying (changing OccNames only), not freshening, in accordance with +that Note. +-} + +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [TyVar] -- Extra eta tyvars + -> [CoVar] -- possibly stale covars + -> TyCon -- family/newtype TyCon (for error-checking only) + -> [Type] -- LHS patterns + -> Type -- RHS + -> [Role] + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs eta_tvs cvs ax_tc lhs rhs roles loc + = -- See Note [CoAxioms are homogeneous] in Core.Coercion.Axiom + ASSERT( typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs ) + CoAxBranch { cab_tvs = tvs' + , cab_eta_tvs = eta_tvs' + , cab_cvs = cvs' + , cab_lhs = tidyTypes env lhs + , cab_roles = roles + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env1, tvs') = tidyVarBndrs init_tidy_env tvs + (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs + (env, cvs') = tidyVarBndrs env2 cvs + -- See Note [Tidy axioms when we build them] + -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom + + init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_tidy_env = mkEmptyTidyEnv init_occ_env + -- See Note [Always number wildcard types in CoAxBranch] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = manyBranches (computeAxiomIncomps branches) } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Role -> Name + -> [TyVar] -> [TyVar] -> [CoVar] + -> TyCon -> [Type] -> Type + -> CoAxiom Unbranched +-- Make a single-branch CoAxiom, including making the branch itself +-- Used for both type family (Nominal) and data family (Representational) +-- axioms, hence passing in the Role +mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = role + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs eta_tvs cvs fam_tc lhs_tys rhs_ty + (map (const Nominal) tvs) + (getSrcSpan ax_name) + +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCoAxiom name tycon tvs roles rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon + , co_ax_role = Representational + , co_ax_tc = tycon + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs [] [] tycon (mkTyVarTys tvs) rhs_ty + roles (getSrcSpan name) + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +-} + +-- when matching a type family application, we get a FamInst, +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst + , fim_tys :: [Type] + , fim_cos :: [Coercion] + } + -- See Note [Over-saturated matches] + +instance Outputable FamInstMatch where + ppr (FamInstMatch { fim_instance = inst + , fim_tys = tys + , fim_cos = cos }) + = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos + +lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] +lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc + = get pkg_ie ++ get home_ie + where + get ie = case lookupUDFM ie fam_tc of + Nothing -> [] + Just (FamIE fis) -> fis + +lookupFamInstEnv + :: FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnv + = lookup_fam_inst_env match + where + match _ _ tpl_tys tys = tcMatchTys tpl_tys tys + +lookupFamInstEnvConflicts + :: FamInstEnvs + -> FamInst -- Putative new instance + -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env my_unify envs fam tys + where + (fam, tys) = famInstSplitLHS fam_inst + -- In example above, fam tys' = F [b] + + my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just noSubst + -- Note [Family instance overlap conflicts] + + noSubst = panic "lookupFamInstEnvConflicts noSubst" + new_branch = coAxiomSingleBranch new_axiom + +-------------------------------------------------------------------------------- +-- Type family injectivity checking bits -- +-------------------------------------------------------------------------------- + +{- Note [Verifying injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Injectivity means that the RHS of a type family uniquely determines the LHS (see +Note [Type inference for type families with injectivity]). The user informs us about +injectivity using an injectivity annotation and it is GHC's task to verify that +this annotation is correct w.r.t. type family equations. Whenever we see a new +equation of a type family we need to make sure that adding this equation to the +already known equations of a type family does not violate the injectivity annotation +supplied by the user (see Note [Injectivity annotation]). Of course if the type +family has no injectivity annotation then no check is required. But if a type +family has injectivity annotation we need to make sure that the following +conditions hold: + +1. For each pair of *different* equations of a type family, one of the following + conditions holds: + + A: RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution + then it must be possible to unify the LHSs under the same substitution. + Example: + + type family FunnyId a = r | r -> a + type instance FunnyId Int = Int + type instance FunnyId a = a + + RHSs of these two equations unify under [ a |-> Int ] substitution. + Under this substitution LHSs are equal therefore these equations don't + violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some + substitution then either the LHSs unify under the same substitution or + the LHS of the latter equation is overlapped by earlier equations. + Example 1: + + type family SwapIntChar a = r | r -> a where + SwapIntChar Int = Char + SwapIntChar Char = Int + SwapIntChar a = a + + Say we are checking the last two equations. RHSs unify under [ a |-> + Int ] substitution but LHSs don't. So we apply the substitution to LHS + of last equation and check whether it is overlapped by any of previous + equations. Since it is overlapped by the first equation we conclude + that pair of last two equations does not violate injectivity + annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts) + + A special case of B is when RHSs unify with an empty substitution ie. they + are identical. + + If any of the above two conditions holds we conclude that the pair of + equations does not violate injectivity annotation. But if we find a pair + of equations where neither of the above holds we report that this pair + violates injectivity annotation because for a given RHS we don't have a + unique LHS. (Note that (B) actually implies (A).) + + Note that we only take into account these LHS patterns that were declared + as injective. + +2. If an RHS of a type family equation is a bare type variable then + all LHS variables (including implicit kind variables) also have to be bare. + In other words, this has to be a sole equation of that type family and it has + to cover all possible patterns. So for example this definition will be + rejected: + + type family W1 a = r | r -> a + type instance W1 [a] = a + + If it were accepted we could call `W1 [W1 Int]`, which would reduce to + `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, + which is bogus. Checked FamInst.bareTvInRHSViolated. + +3. If the RHS of a type family equation is a type family application then the type + family is rejected as not injective. This is checked by FamInst.isTFHeaded. + +4. If a LHS type variable that is declared as injective is not mentioned in an + injective position in the RHS then the type family is rejected as not + injective. "Injective position" means either an argument to a type + constructor or argument to a type family on injective position. + There are subtleties here. See Note [Coverage condition for injective type families] + in FamInst. + +Check (1) must be done for all family instances (transitively) imported. Other +checks (2-4) should be done just for locally written equations, as they are checks +involving just a single equation, not about interactions. Doing the other checks for +imported equations led to #17405, as the behavior of check (4) depends on +-XUndecidableInstances (see Note [Coverage condition for injective type families] in +FamInst), which may vary between modules. + +See also Note [Injective type families] in GHC.Core.TyCon +-} + + +-- | Check whether an open type family equation can be added to already existing +-- instance environment without causing conflicts with supplied injectivity +-- annotations. Returns list of conflicting axioms (type instance +-- declarations). +lookupFamInstEnvInjectivityConflicts + :: [Bool] -- injectivity annotation for this type family instance + -- INVARIANT: list contains at least one True value + -> FamInstEnvs -- all type instances seens so far + -> FamInst -- new type instance that we're checking + -> [CoAxBranch] -- conflicting instance declarations +lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) + fam_inst@(FamInst { fi_axiom = new_axiom }) + -- See Note [Verifying injectivity annotation]. This function implements + -- check (1.B1) for open type families described there. + = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + where + fam = famInstTyCon fam_inst + new_branch = coAxiomSingleBranch new_axiom + + -- filtering function used by `lookup_inj_fam_conflicts` to check whether + -- a pair of equations conflicts with the injectivity annotation. + isInjConflict (FamInst { fi_axiom = old_axiom }) + | InjectivityAccepted <- + injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch + = False -- no conflict + | otherwise = True + + lookup_inj_fam_conflicts ie + | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam + = map (coAxiomSingleBranch . fi_axiom) $ + filter isInjConflict insts + | otherwise = [] + + +-------------------------------------------------------------------------------- +-- Type family overlap checking bits -- +-------------------------------------------------------------------------------- + +{- +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. +-} + +------------------------------------------------------------ +-- Might be a one-way match or a unifier +type MatchFun = FamInst -- The FamInst template + -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst + -> [Type] -- Target to match against + -> Maybe TCvSubst + +lookup_fam_inst_env' -- The worker, local to this module + :: MatchFun + -> FamInstEnv + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] +lookup_fam_inst_env' match_fun ie fam match_tys + | isOpenFamilyTyCon fam + , Just (FamIE insts) <- lookupUDFM ie fam + = find insts -- The common case + | otherwise = [] + where + + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 + = (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + substCoVars subst tpl_cvs + }) + : find rest + + -- No match => try next + | otherwise + = find rest + where + (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isTypeFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + rough_tcs = roughMatchTcs match_tys1 + in (rough_tcs, match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) + +lookup_fam_inst_env -- The worker, local to this module + :: MatchFun + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys + +{- +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) +The "extra" type argument [Char] just stays on the end. + +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see + Note [Eta reduction for data families]. +-} + +-- checks if one LHS is dominated by a list of other branches +-- in other words, if an application would match the first LHS, it is guaranteed +-- to match at least one of the others. The RHSs are ignored. +-- This algorithm is conservative: +-- True -> the LHS is definitely covered by the others +-- False -> no information +-- It is currently (Oct 2012) used only for generating errors for +-- inaccessible branches. If these errors go unreported, no harm done. +-- This is defined here to avoid a dependency from CoAxiom to Unify +isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool +isDominatedBy branch branches + = or $ map match branches + where + lhs = coAxBranchLHS branch + match (CoAxBranch { cab_lhs = tys }) + = isJust $ tcMatchTys tys lhs + +{- +************************************************************************ +* * + Choosing an axiom application +* * +************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: +-} + +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe (Coercion, Type) +-- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational +-- It does *not* normalise the type arguments first, so this may not +-- go as far as you want. If you want normalised type arguments, +-- use normaliseTcArgs first. +-- +-- The TyCon can be oversaturated. +-- Works on both open and closed families +-- +-- Always returns a *homogeneous* coercion -- type family reductions are always +-- homogeneous +reduceTyFamApp_maybe envs role tc tys + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families + , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } + , fim_tys = inst_tys + , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys + -- NB: Allow multiple matches because of compatible overlap + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + ty = coercionRKind co + in Just (co, ty) + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys inst_cos + ty = coercionRKind co + in Just (co, ty) + + | Just ax <- isBuiltInSynFamTyCon_maybe tc + , Just (coax,ts,ty) <- sfMatchFam ax tys + = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) + in Just (co, ty) + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys, inst_cos) + <- findBranch (unMkBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } + +-- The axiom must *not* be oversaturated +findBranch :: Array BranchIndex CoAxBranch + -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N +findBranch branches target_tys + = foldr go Nothing (assocs branches) + where + go :: (BranchIndex, CoAxBranch) + -> Maybe (BranchIndex, [Type], [Coercion]) + -> Maybe (BranchIndex, [Type], [Coercion]) + go (index, branch) other + = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs + , cab_incomps = incomps }) = branch + in_scope = mkInScopeSet (unionVarSets $ + map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + -- See Note [Flattening] below + flattened_target = flattenTys in_scope target_tys + in case tcMatchTys tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | apartnessCheck flattened_target branch + -> -- matching worked & we're apart from all incompatible branches. + -- success + ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) + + -- failure. keep looking + _ -> other + +-- | Do an apartness check, as described in the "Closed Type Families" paper +-- (POPL '14). This should be used when determining if an equation +-- ('CoAxBranch') of a closed type family can be used to reduce a certain target +-- type family application. +apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure + -- they're flattened! See Note [Flattening]. + -- (NB: This "flat" is a different + -- "flat" than is used in TcFlatten.) + -> CoAxBranch -- ^ the candidate equation we wish to use + -- Precondition: this matches the target + -> Bool -- ^ True <=> equation can fire +apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) + = all (isSurelyApart + . tcUnifyTysFG (const BindMe) flattened_target + . coAxBranchLHS) incomps + where + isSurelyApart SurelyApart = True + isSurelyApart _ = False + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +Note [Normalising types] +~~~~~~~~~~~~~~~~~~~~~~~~ +The topNormaliseType function removes all occurrences of type families +and newtypes from the top-level structure of a type. normaliseTcApp does +the type family lookup and is fairly straightforward. normaliseType is +a little more involved. + +The complication comes from the fact that a type family might be used in the +kind of a variable bound in a forall. We wish to remove this type family +application, but that means coming up with a fresh variable (with the new +kind). Thus, we need a substitution to be built up as we recur through the +type. However, an ordinary TCvSubst just won't do: when we hit a type variable +whose kind has changed during normalisation, we need both the new type +variable *and* the coercion. We could conjure up a new VarEnv with just this +property, but a usable substitution environment already exists: +LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion. +A LiftingContext maps a type variable to a coercion and a coercion variable to +a pair of coercions. Let's ignore coercion variables for now. Because the +coercion a type variable maps to contains the destination type (via +coercionKind), we don't need to store that destination type separately. Thus, +a LiftingContext has what we need: a map from type variables to (Coercion, +Type) pairs. + +We also benefit because we can piggyback on the liftCoSubstVarBndr function to +deal with binders. However, I had to modify that function to work with this +application. Thus, we now have liftCoSubstVarBndrUsing, which takes +a function used to process the kind of the binder. We don't wish +to lift the kind, but instead normalise it. So, we pass in a callback function +that processes the kind of the binder. + +After that brilliant explanation of all this, I'm sure you've forgotten the +dangling reference to coercion variables. What do we do with those? Nothing at +all. The point of normalising types is to remove type family applications, but +there's no sense in removing these from coercions. We would just get back a +new coercion witnessing the equality between the same types as the original +coercion. Because coercions are irrelevant anyway, there is no point in doing +this. So, whenever we encounter a coercion, we just say that it won't change. +That's what the CoercionTy case is doing within normalise_type. + +Note [Normalisation and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be a bit careful about normalising in the presence of type +synonyms (#13035). Suppose S is a type synonym, and we have + S t1 t2 +If S is family-free (on its RHS) we can just normalise t1 and t2 and +reconstruct (S t1' t2'). Expanding S could not reveal any new redexes +because type families are saturated. + +But if S has a type family on its RHS we expand /before/ normalising +the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them +after expansion, and that can lead to /exponential/ behaviour; see #13035. + +Notice, though, that expanding first can in principle duplicate t1,t2, +which might contain redexes. I'm sure you could conjure up an exponential +case by that route too, but it hasn't happened in practice yet! +-} + +topNormaliseType :: FamInstEnvs -> Type -> Type +topNormaliseType env ty = case topNormaliseType_maybe env ty of + Just (_co, ty') -> ty' + Nothing -> ty + +topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) + +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- returning an appropriate Representational coercion. Specifically, if +-- topNormaliseType_maybe env ty = Just (co, ty') +-- then +-- (a) co :: ty ~R ty' +-- (b) ty' is not a newtype, and is not a type-family or data-family redex +-- +-- However, ty' can be something like (Maybe (F ty)), where +-- (F ty) is a redex. +-- +-- Always operates homogeneously: the returned type has the same kind as the +-- original type, and the returned coercion is always homogeneous. +topNormaliseType_maybe env ty + = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty + ; return $ case mkind_co of + MRefl -> (co, nty) + MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo Representational nty + (mkSymCo kind_co) co + in (final_co, nty_casted) } + where + stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper + + combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) + + unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) + unwrapNewTypeStepper' rec_nts tc tys + = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + + -- second coercion below is the kind coercion relating the original type's kind + -- to the normalised type's kind + tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in + case reduceTyFamApp_maybe env Representational tc ntys of + Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co) + _ -> NS_Done + +--------------- +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +-- See comments on normaliseType for the arguments of this function +normaliseTcApp env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_app tc tys + +-- See Note [Normalising types] about the LiftingContext +normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) +normalise_tc_app tc tys + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , not (isFamFreeTyCon tc) -- Expand and try again + = -- A synonym with type families in the RHS + -- Expand and try again + -- See Note [Normalisation and type synonyms] + normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + + | isFamilyTyCon tc + = -- A type-family application + do { env <- getEnv + ; role <- getRole + ; (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; case reduceTyFamApp_maybe env role tc ntys of + Just (first_co, ty') + -> do { (rest_co,nty) <- normalise_type ty' + ; return (assemble_result role nty + (args_co `mkTransCo` first_co `mkTransCo` rest_co) + res_co) } + _ -> -- No unique matching family instance exists; + -- we do not do anything + return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + | otherwise + = -- A synonym with no type families in the RHS; or data type etc + -- Just normalise the arguments and rebuild + do { (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; role <- getRole + ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + where + assemble_result :: Role -- r, ambient role in NormM monad + -> Type -- nty, result type, possibly of changed kind + -> Coercion -- orig_ty ~r nty, possibly heterogeneous + -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) + -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) + -- where nty_casted has same kind as orig_ty + assemble_result r nty orig_to_nty kind_co + = ( final_co, nty_old_kind ) + where + nty_old_kind = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty + +--------------- +-- | Normalise arguments to a tycon +normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances + -> Role -- ^ desired role of output coercion + -> TyCon -- ^ tc + -> [Type] -- ^ tys + -> (Coercion, [Type], CoercionN) + -- ^ co :: tc tys ~ tc new_tys + -- NB: co might not be homogeneous + -- last coercion :: kind(tc tys) ~ kind(tc new_tys) +normaliseTcArgs env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_args tc tys + +normalise_tc_args :: TyCon -> [Type] -- tc tys + -> NormM (Coercion, [Type], CoercionN) + -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys; might not be homogeneous + -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) +normalise_tc_args tc tys + = do { role <- getRole + ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys + ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> (Coercion, Type) +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +normalise_type :: Type -- old type + -> NormM (Coercion, Type) -- (coercion, new type), where + -- co :: old-type ~ new_type +-- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) +-- Returns with Refl if nothing happens +-- Does nothing to newtypes +-- The returned coercion *must* be *homogeneous* +-- See Note [Normalising types] +-- Try not to disturb type synonyms if possible + +normalise_type ty + = go ty + where + go (TyConApp tc tys) = normalise_tc_app tc tys + go ty@(LitTy {}) = do { r <- getRole + ; return (mkReflCo r ty, ty) } + + go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] + + go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + = do { (co1, nty1) <- go ty1 + ; (co2, nty2) <- go ty2 + ; r <- getRole + ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } + go (ForAllTy (Bndr tcvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar + ; (co, nty) <- withLC lc' $ normalise_type ty + ; let tv2 = setTyVarKind tv' ki' + ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } + go (TyVarTy tv) = normalise_tyvar tv + go (CastTy ty co) + = do { (nco, nty) <- go ty + ; lc <- getLC + ; let co' = substRightCo lc co + ; return (castCoercionKind nco Nominal ty nty co co' + , mkCastTy nty co') } + go (CoercionTy co) + = do { lc <- getLC + ; r <- getRole + ; let right_co = substRightCo lc co + ; return ( mkProofIrrelCo r + (liftCoSubst Nominal lc (coercionType co)) + co right_co + , mkCoercionTy right_co ) } + + go_app_tys :: Type -- function + -> [Type] -- args + -> NormM (Coercion, Type) + -- cf. TcFlatten.flatten_app_ty_args + go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) + go_app_tys fun_ty arg_tys + = do { (fun_co, nfun) <- go fun_ty + ; case tcSplitTyConApp_maybe nfun of + Just (tc, xis) -> + do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) + -- flatten_app_ty_args avoids redundantly processing the xis, + -- but that's a much more performance-sensitive function. + -- This type normalisation is not called in a loop. + ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } + Nothing -> + do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) + (repeat Nominal) + arg_tys + ; role <- getRole + ; let nty = mkAppTys nfun nargs + nco = mkAppCos fun_co args_cos + nty_casted = nty `mkCastTy` mkSymCo res_co + final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco + ; return (final_co, nty_casted) } } + +normalise_args :: Kind -- of the function + -> [Role] -- roles at which to normalise args + -> [Type] -- args + -> NormM ([Coercion], [Type], Coercion) +-- returns (cos, xis, res_co), where each xi is the normalised +-- version of the corresponding type, each co is orig_arg ~ xi, +-- and the res_co :: kind(f orig_args) ~ kind(f xis) +-- NB: The xis might *not* have the same kinds as the input types, +-- but the resulting application *will* be well-kinded +-- cf. TcFlatten.flatten_args_slow +normalise_args fun_ki roles args + = do { normed_args <- zipWithM normalise1 roles args + ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args + ; return (map mkSymCo cos, xis, mkSymCo res_co) } + where + (ki_binders, inner_ki) = splitPiTys fun_ki + fvs = tyCoVarsOfTypes args + + -- flattener conventions are different from ours + impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) + impedance_match action = do { (co, ty) <- action + ; return (ty, mkSymCo co) } + + normalise1 role ty + = impedance_match $ withRole role $ normalise_type ty + +normalise_tyvar :: TyVar -> NormM (Coercion, Type) +normalise_tyvar tv + = ASSERT( isTyVar tv ) + do { lc <- getLC + ; r <- getRole + ; return $ case liftCoSubstTyVar lc r tv of + Just co -> (co, coercionRKind co) + Nothing -> (mkReflCo r ty, ty) } + where ty = mkTyVarTy tv + +normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) +normalise_var_bndr tcvar + -- works for both tvar and covar + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + deriving (Functor) + +initNormM :: FamInstEnvs -> Role + -> TyCoVarSet -- the in-scope variables + -> NormM a -> a +initNormM env role vars (NormM thing_inside) + = thing_inside env lc role + where + in_scope = mkInScopeSet vars + lc = emptyLiftingContext in_scope + +getRole :: NormM Role +getRole = NormM (\ _ _ r -> r) + +getLC :: NormM LiftingContext +getLC = NormM (\ _ lc _ -> lc) + +getEnv :: NormM FamInstEnvs +getEnv = NormM (\ env _ _ -> env) + +withRole :: Role -> NormM a -> NormM a +withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r + +withLC :: LiftingContext -> NormM a -> NormM a +withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r + +instance Monad NormM where + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap + +{- +************************************************************************ +* * + Flattening +* * +************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~ +As described in "Closed type families with overlapping equations" +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +we need to flatten core types before unifying them, when checking for "surely-apart" +against earlier equations of a closed type family. +Flattening means replacing all top-level uses of type functions with +fresh variables, *taking care to preserve sharing*. That is, the type +(Either (F a b) (F a b)) should flatten to (Either c c), never (Either +c d). + +Here is a nice example of why it's all necessary: + + type family F a b where + F Int Bool = Char + F a b = Double + type family G a -- open, no instances + +How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, +while the second equation does. But, before reducing, we must make sure that the +target can never become (F Int Bool). Well, no matter what G Float becomes, it +certainly won't become *both* Int and Bool, so indeed we're safe reducing +(F (G Float) (G Float)) to Double. + +This is necessary not only to get more reductions (which we might be +willing to give up on), but for substitutivity. If we have (F x x), we +can see that (F x x) can reduce to Double. So, it had better be the +case that (F blah blah) can reduce to Double, no matter what (blah) +is! Flattening as done below ensures this. + +The algorithm works by building up a TypeMap TyVar, mapping +type family applications to fresh variables. This mapping must +be threaded through all the function calls, as any entry in +the mapping must be propagated to all future nodes in the tree. + +The algorithm also must track the set of in-scope variables, in +order to make fresh variables as it flattens. (We are far from a +source of fresh Uniques.) See Wrinkle 2, below. + +There are wrinkles, of course: + +1. The flattening algorithm must account for the possibility + of inner `forall`s. (A `forall` seen here can happen only + because of impredicativity. However, the flattening operation + is an algorithm in Core, which is impredicative.) + Suppose we have (forall b. F b) -> (forall b. F b). Of course, + those two bs are entirely unrelated, and so we should certainly + not flatten the two calls F b to the same variable. Instead, they + must be treated separately. We thus carry a substitution that + freshens variables; we must apply this substitution (in + `coreFlattenTyFamApp`) before looking up an application in the environment. + Note that the range of the substitution contains only TyVars, never anything + else. + + For the sake of efficiency, we only apply this substitution when absolutely + necessary. Namely: + + * We do not perform the substitution at all if it is empty. + * We only need to worry about the arguments of a type family that are within + the arity of said type family, so we can get away with not applying the + substitution to any oversaturated type family arguments. + * Importantly, we do /not/ achieve this substitution by recursively + flattening the arguments, as this would be wrong. Consider `F (G a)`, + where F and G are type families. We might decide that `F (G a)` flattens + to `beta`. Later, the substitution is non-empty (but does not map `a`) and + so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, + `F gamma` is unknown, and so we flatten it to `delta`, but it really + should have been `beta`! Argh! + + Moral of the story: instead of flattening the arguments, just substitute + them directly. + +2. There are two different reasons we might add a variable + to the in-scope set as we work: + + A. We have just invented a new flattening variable. + B. We have entered a `forall`. + + Annoying here is that in-scope variable source (A) must be + threaded through the calls. For example, consider (F b -> forall c. F c). + Suppose that, when flattening F b, we invent a fresh variable c. + Now, when we encounter (forall c. F c), we need to know c is already in + scope so that we locally rename c to c'. However, if we don't thread through + the in-scope set from one argument of (->) to the other, we won't know this + and might get very confused. + + In contrast, source (B) increases only as we go deeper, as in-scope sets + normally do. However, even here we must be careful. The TypeMap TyVar that + contains mappings from type family applications to freshened variables will + be threaded through both sides of (forall b. F b) -> (forall b. F b). We + thus must make sure that the two `b`s don't get renamed to the same b1. (If + they did, then looking up `F b1` would yield the same flatten var for + each.) So, even though `forall`-bound variables should really be in the + in-scope set only when they are in scope, we retain these variables even + outside of their scope. This ensures that, if we encounter a fresh + `forall`-bound b, we will rename it to b2, not b1. Note that keeping a + larger in-scope set than strictly necessary is always OK, as in-scope sets + are only ever used to avoid collisions. + + Sadly, the freshening substitution described in (1) really mustn't bind + variables outside of their scope: note that its domain is the *unrenamed* + variables. This means that the substitution gets "pushed down" (like a + reader monad) while the in-scope set gets threaded (like a state monad). + Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; + instead, we just carry a TvSubstEnv down, tying it to the InScopeSet + traveling separately as necessary. + +3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: + + type family F ty_1 ... ty_k :: res_k + + It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a + flattening skolem. But we must instead flatten it to + `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the + type family. + + Why is this better? Consider the following concrete example from #16995: + + type family Param :: Type -> Type + + type family LookupParam (a :: Type) :: Type where + LookupParam (f Char) = Bool + LookupParam x = Int + + foo :: LookupParam (Param ()) + foo = 42 + + In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to + `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if + `alpha` is apart from `f Char`, so it won't fall through to the second + equation. But since the `Param` type family has arity 0, we can instead + flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is + apart from `f Char`, permitting the second equation to be reached. + + Not only does this allow more programs to be accepted, it's also important + for correctness. Not doing this was the root cause of the Core Lint error + in #16995. + +flattenTys is defined here because of module dependencies. +-} + +data FlattenEnv + = FlattenEnv { fe_type_map :: TypeMap TyVar + -- domain: exactly-saturated type family applications + -- range: fresh variables + , fe_in_scope :: InScopeSet } + -- See Note [Flattening] + +emptyFlattenEnv :: InScopeSet -> FlattenEnv +emptyFlattenEnv in_scope + = FlattenEnv { fe_type_map = emptyTypeMap + , fe_in_scope = in_scope } + +updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv +updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } + +flattenTys :: InScopeSet -> [Type] -> [Type] +-- See Note [Flattening] +-- NB: the returned types may mention fresh type variables, +-- arising from the flattening. We don't return the +-- mapping from those fresh vars to the ty-fam +-- applications they stand for (we could, but no need) +flattenTys in_scope tys + = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys + +coreFlattenTys :: TvSubstEnv -> FlattenEnv + -> [Type] -> (FlattenEnv, [Type]) +coreFlattenTys subst = mapAccumL (coreFlattenTy subst) + +coreFlattenTy :: TvSubstEnv -> FlattenEnv + -> Type -> (FlattenEnv, Type) +coreFlattenTy subst = go + where + go env ty | Just ty' <- coreView ty = go env ty' + + go env (TyVarTy tv) + | Just ty <- lookupVarEnv subst tv = (env, ty) + | otherwise = let (env', ki) = go env (tyVarKind tv) in + (env', mkTyVarTy $ setTyVarKind tv ki) + go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, AppTy ty1' ty2') + go env (TyConApp tc tys) + -- NB: Don't just check if isFamilyTyCon: this catches *data* families, + -- which are generative and thus can be preserved during flattening + | not (isGenerativeTyCon tc Nominal) + = coreFlattenTyFamApp subst env tc tys + + | otherwise + = let (env', tys') = coreFlattenTys subst env tys in + (env', mkTyConApp tc tys') + + go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, ty { ft_arg = ty1', ft_res = ty2' }) + + go env (ForAllTy (Bndr tv vis) ty) + = let (env1, subst', tv') = coreFlattenVarBndr subst env tv + (env2, ty') = coreFlattenTy subst' env1 ty in + (env2, ForAllTy (Bndr tv' vis) ty') + + go env ty@(LitTy {}) = (env, ty) + + go env (CastTy ty co) + = let (env1, ty') = go env ty + (env2, co') = coreFlattenCo subst env1 co in + (env2, CastTy ty' co') + + go env (CoercionTy co) + = let (env', co') = coreFlattenCo subst env co in + (env', CoercionTy co') + +-- when flattening, we don't care about the contents of coercions. +-- so, just return a fresh variable of the right (flattened) type +coreFlattenCo :: TvSubstEnv -> FlattenEnv + -> Coercion -> (FlattenEnv, Coercion) +coreFlattenCo subst env co + = (env2, mkCoVarCo covar) + where + (env1, kind') = coreFlattenTy subst env (coercionType co) + covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' + -- Add the covar to the FlattenEnv's in-scope set. + -- See Note [Flattening], wrinkle 2A. + env2 = updateInScopeSet env1 (flip extendInScopeSet covar) + +coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv + -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) +coreFlattenVarBndr subst env tv + = (env2, subst', tv') + where + -- See Note [Flattening], wrinkle 2B. + kind = varType tv + (env1, kind') = coreFlattenTy subst env kind + tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') + subst' = extendVarEnv subst tv (mkTyVarTy tv') + env2 = updateInScopeSet env1 (flip extendInScopeSet tv') + +coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv + -> TyCon -- type family tycon + -> [Type] -- args, already flattened + -> (FlattenEnv, Type) +coreFlattenTyFamApp tv_subst env fam_tc fam_args + = case lookupTypeMap type_map fam_ty of + Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') + Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway in_scope $ + mkTyVar tyvar_name (typeKind fam_ty) + + ty' = mkAppTys (mkTyVarTy tv) leftover_args' + env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv + , fe_in_scope = extendInScopeSet in_scope tv } + in (env'', ty') + where + arity = tyConArity fam_tc + tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv + (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) + splitAt arity fam_args + -- Apply the substitution before looking up an application in the + -- environment. See Note [Flattening], wrinkle 1. + -- NB: substTys short-cuts the common case when the substitution is empty. + sat_fam_args' = substTys tcv_subst sat_fam_args + (env', leftover_args') = coreFlattenTys tv_subst env leftover_args + -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], + -- wrinkle 3), so we split it into the arguments needed to saturate it + -- (sat_fam_args') and the rest (leftover_args') + fam_ty = mkTyConApp fam_tc sat_fam_args' + FlattenEnv { fe_type_map = type_map + , fe_in_scope = in_scope } = env' + +mkFlattenFreshTyName :: Uniquable a => a -> Name +mkFlattenFreshTyName unq + = mkSysTvName (getUnique unq) (fsLit "flt") + +mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar +mkFlattenFreshCoVar in_scope kind + = let uniq = unsafeGetFreshLocalUnique in_scope + name = mkSystemVarName uniq (fsLit "flc") + in mkCoVar name kind diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/InstEnv.hs @@ -0,0 +1,1030 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to TcInstDcls and TcDeriv. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module GHC.Core.InstEnv ( + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, + instanceDFunId, updateClsInstDFun, instanceRoughTcs, + fuzzyClsInstCmp, orphNamesOfClsInst, + + InstEnvs(..), VisibleOrphanModules, InstEnv, + emptyInstEnv, extendInstEnv, + deleteFromInstEnv, deleteDFunFromInstEnv, + identicalClsInstHead, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, + memberInstEnv, + instIsVisible, + classInstances, instanceBindFun, + instanceCantMatch, roughMatchTcs, + isOverlappable, isOverlapping, isIncoherent + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcType -- InstEnv is really part of the type checker, + -- and depends on TcType in many ways +import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import GHC.Types.Module +import GHC.Core.Class +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Core.Unify +import Outputable +import ErrUtils +import GHC.Types.Basic +import GHC.Types.Unique.DFM +import Util +import GHC.Types.Id +import Data.Data ( Data ) +import Data.Maybe ( isJust, isNothing ) + +{- +************************************************************************ +* * + ClsInst: the data type for type-class instances +* * +************************************************************************ +-} + +-- | A type-class instance. Note that there is some tricky laziness at work +-- here. See Note [ClsInst laziness and the rough-match fields] for more +-- details. +data ClsInst + = ClsInst { -- Used for "rough matching"; see + -- Note [ClsInst laziness and the rough-match fields] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + is_cls_nm :: Name -- ^ Class name + , is_tcs :: [Maybe Name] -- ^ Top of type args + + -- | @is_dfun_name = idName . is_dfun@. + -- + -- We use 'is_dfun_name' for the visibility check, + -- 'instIsVisible', which needs to know the 'Module' which the + -- dictionary is defined in. However, we cannot use the 'Module' + -- attached to 'is_dfun' since doing so would mean we would + -- potentially pull in an entire interface file unnecessarily. + -- This was the cause of #12367. + , is_dfun_name :: Name + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: [TyVar] -- Fresh template tyvars for full match + -- See Note [Template tyvars are fresh] + , is_cls :: Class -- The real class + , is_tys :: [Type] -- Full arg types (mentioning is_tvs) + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + -- (modulo alpha conversion) + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan + } + deriving Data + +-- | A fuzzy comparison function for class instances, intended for sorting +-- instances before displaying them to the user. +fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering +fuzzyClsInstCmp x y = + stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` + mconcat (map cmp (zip (is_tcs x) (is_tcs y))) + where + cmp (Nothing, Nothing) = EQ + cmp (Nothing, Just _) = LT + cmp (Just _, Nothing) = GT + cmp (Just x, Just y) = stableNameCmp x y + +isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool +isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) +isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) +isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) + +{- +Note [ClsInst laziness and the rough-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is +otherwise unused in the program. Then it's stupid to load B.hi, the data type +declaration for B.T -- and perhaps further instance declarations! + +We avoid this as follows: + +* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's + content. + +* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys + contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we + poke any of these fields we'll typecheck the DFunId declaration, and hence + pull in interfaces that it refers to. See Note [Proper-match fields]. + +* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and + is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking + inside the DFunId. The rough-match fields allow us to say "definitely does not + match", based only on Names. + + This laziness is very important; see #12367. Try hard to avoid pulling on + the structured fields unless you really need the instance. + +* Another place to watch is InstEnv.instIsVisible, which needs the module to + which the ClsInst belongs. We can get this from is_dfun_name. + +* In is_tcs, + Nothing means that this type arg is a type variable + + (Just n) means that this type arg is a + TyConApp with a type constructor of n. + This is always a real tycon, never a synonym! + (Two different synonyms might match, but two + different real tycons can't.) + NB: newtypes are not transparent, though! +-} + +{- +Note [Template tyvars are fresh] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs field of a ClsInst has *completely fresh* tyvars. +That is, they are + * distinct from any other ClsInst + * distinct from any tyvars free in predicates that may + be looked up in the class instance environment +Reason for freshness: we use unification when checking for overlap +etc, and that requires the tyvars to be distinct. + +The invariant is checked by the ASSERT in lookupInstEnv'. + +Note [Proper-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs, is_cls, is_tys fields are simply cached values, pulled +out (lazily) from the dfun id. They are cached here simply so +that we don't need to decompose the DFunId each time we want +to match it. The hope is that the rough-match fields mean +that we often never poke the proper-match fields. + +However, note that: + * is_tvs must be a superset of the free vars of is_tys + + * is_tvs, is_tys may be alpha-renamed compared to the ones in + the dfun Id + +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. +-} + +instanceDFunId :: ClsInst -> DFunId +instanceDFunId = is_dfun + +updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +updateClsInstDFun tidy_dfun ispec + = ispec { is_dfun = tidy_dfun (is_dfun ispec) } + +instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs = is_tcs + + +instance NamedThing ClsInst where + getName ispec = getName (is_dfun ispec) + +instance Outputable ClsInst where + ppr = pprInstance + +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstance ispec + = hang (pprInstanceHdr ispec) + 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) + , whenPprDebug (ppr (is_dfun ispec)) ]) + +-- * pprInstanceHdr is used in VStudio to populate the ClassView tree +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) + +pprInstances :: [ClsInst] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: ClsInst -> ([TyVar], Class, [Type]) +-- Returns the head, using the fresh tyavs from the ClsInst +instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) + = (tvs, cls, tys) + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + +-- | Collects the names of concrete types and type constructors that make +-- up the head of a class instance. For instance, given `class Foo a b`: +-- +-- `instance Foo (Either (Maybe Int) a) Bool` would yield +-- [Either, Maybe, Int, Bool] +-- +-- Used in the implementation of ":info" in GHCi. +-- +-- The 'tcSplitSigmaTy' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +orphNamesOfClsInst :: ClsInst -> NameSet +orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) + = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm + +instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) +-- Decomposes the DFunId +instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag + -> [TyVar] -> Class -> [Type] + -> ClsInst +-- Used for local instances, where we can safely pull on the DFunId. +-- Consider using newClsInst instead; this will also warn if +-- the instance is an orphan. +mkLocalInstance dfun oflag tvs cls tys + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs + , is_dfun_name = dfun_name + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = roughMatchTcs tys + , is_orphan = orph + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + (cls_tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns | null fds = [choose_one arg_names] + | otherwise = map do_one fds + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one nss = chooseOrphanAnchor (unionNameSets nss) + +mkImportedInstance :: Name -- ^ the name of the class + -> [Maybe Name] -- ^ the types which the class was applied to + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? + -> ClsInst +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +-- The bound tyvars of the dfun are guaranteed fresh, because +-- the dfun has been typechecked out of the same interface file +mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs, is_tys = tys + , is_dfun_name = dfun_name + , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_orphan = orphan } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + +{- +Note [When exactly is an instance decl an orphan?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + (see GHC.Iface.Make.instanceToIfaceInst, which implements this) +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. + +Functional dependencies complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + + +************************************************************************ +* * + InstEnv, ClsInstEnv +* * +************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun +-} + +--------------------------------------------------- +{- +Note [InstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn InstEnvs into a list in some places that don't directly affect +the ABI. That happens when we create output for `:info`. +Unfortunately that nondeterminism is nonlocal and it's hard to tell what it +affects without following a chain of functions. It's also easy to accidentally +make that nondeterminism affect the ABI. Furthermore the envs should be +relatively small, so it should be free to use deterministic maps here. +Testing with nofib and validate detected no difference between UniqFM and +UniqDFM. See also Note [Deterministic UniqFM] +-} + +type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class + -- See Note [InstEnv determinism] + +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, -- External-package instances + ie_local :: InstEnv, -- Home-package instances + ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively + -- reachable from the module being compiled + -- See Note [Instance lookup and orphan instances] + } + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet + +newtype ClsInstEnv + = ClsIE [ClsInst] -- The instances for a particular class, in any order + +instance Outputable ClsInstEnv where + ppr (ClsIE is) = pprInstances is + +-- INVARIANTS: +-- * The is_tvs are distinct in each ClsInst +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUDFM + +instEnvElts :: InstEnv -> [ClsInst] +instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] + -- See Note [InstEnv determinism] + +instEnvClasses :: InstEnv -> [Class] +instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] + +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +-- See Note [Instance lookup and orphan instances] +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + = case nameModule_maybe (is_dfun_name ispec) of + Nothing -> True + Just mod | isInteractiveModule mod -> True + | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods + | otherwise -> True + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUDFM env cls of + Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts + Nothing -> [] + +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in TcRnDriver +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = + maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) + (lookupUDFM inst_env cls_nm) + where + identicalDFunType cls1 cls2 = + eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) + +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv +extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUDFM adjust inst_env cls_nm + where + adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) + +deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv +-- Delete a specific instance fron an InstEnv +deleteDFunFromInstEnv inst_env dfun + = adjustUDFM adjust inst_env cls + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + adjust (ClsIE items) = ClsIE (filterOut same_dfun items) + same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' + +identicalClsInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Used for overriding in GHCi +-- Obviously should be insensitive to alpha-renaming +identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys tys1 tys2) + && isJust (tcMatchTys tys2 tys1) + +{- +************************************************************************ +* * + Looking up an instance +* * +************************************************************************ + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +Note [Instance lookup and orphan instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are compiling a module M, and we have a zillion packages +loaded, and we are looking up an instance for C (T W). If we find a +match in module 'X' from package 'p', should be "in scope"; that is, + + is p:X in the transitive closure of modules imported from M? + +The difficulty is that the "zillion packages" might include ones loaded +through earlier invocations of the GHC API, or earlier module loads in GHCi. +They might not be in the dependencies of M itself; and if not, the instances +in them should not be visible. #2182, #8427. + +There are two cases: + * If the instance is *not an orphan*, then module X defines C, T, or W. + And in order for those types to be involved in typechecking M, it + must be that X is in the transitive closure of M's imports. So we + can use the instance. + + * If the instance *is an orphan*, the above reasoning does not apply. + So we keep track of the set of orphan modules transitively below M; + this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. + + If module p:X is in this set, then we can use the instance, otherwise + we can't. + +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + +* Find all instances `I` that *match* the target constraint; that is, the + target constraint is a substitution instance of `I`. These instance + declarations are the *candidates*. + +* Eliminate any candidate `IX` for which both of the following hold: + + - There is another candidate `IY` that is strictly more specific; that + is, `IY` is a substitution instance of `IX` but not vice versa. + + - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This + "either/or" design, rather than a "both/and" design, allow a + client to deliberately override an instance from a library, + without requiring a change to the library.) + +- If exactly one non-incoherent candidate remains, select it. If all + remaining candidates are incoherent, select an arbitrary one. + Otherwise the search fails (i.e. when more than one surviving + candidate is not incoherent). + +- If the selected candidate (from the previous step) is incoherent, the + search succeeds, returning that candidate. + +- If not, find all instances that *unify* with the target constraint, + but do not *match* it. Such non-candidate instances might match when + the target constraint is further instantiated. If all of them are + incoherent, the search succeeds, returning the selected candidate; if + not, the search fails. + +Notice that these rules are not influenced by flag settings in the +client module, where the instances are *used*. These rules make it +possible for a library author to design a library that relies on +overlapping instances without the client having to know. + +Note [Overlapping instances] (NB: these notes are quite old) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely choosing a generic instance when a more specific one +exists. + +--Jeff + +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. + +Simple story: unify, don't match. +-} + +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell + -- (see Note [Safe Haskell Overlapping Instances] in + -- TcSimplify). + +{- +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is a ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated +The instantiating types are (Either TyVar Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will + presumably later become fixed via functional dependencies.) +-} + +-- |Look up an instance in the given instance environment. The given class application must match exactly +-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, +-- yield 'Left errorMessage'. +lookupUniqueInstEnv :: InstEnvs + -> Class -> [Type] + -> Either MsgDoc (ClsInst, [Type]) +lookupUniqueInstEnv instEnv cls tys + = case lookupInstEnv False instEnv cls tys of + ([(inst, inst_tys)], _, _) + | noFlexiVar -> Right (inst, inst_tys') + | otherwise -> Left $ text "flexible type variable:" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + where + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys + _other -> Left $ text "instance not found" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [ClsInst]) -- These don't match but do unify + -- (no incoherent ones in here) +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error message + +lookupInstEnv' ie vis_mods cls tys + = lookup ie + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + + -------------- + lookup env = case lookupUDFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts) -> find [] [] insts + + -------------- + find ms us [] = (ms, us) + find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs + , is_tys = tpl_tys }) : rest) + | not (instIsVisible vis_mods item) + = find ms us rest -- See Note [Instance lookup and orphan instances] + + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tys tys + = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] + -- Ignore ones that are incoherent: Note [Incoherent instances] + | isIncoherent item + = find ms us rest + + | otherwise + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + -- See Note [Template tyvars are fresh] + case tcUnifyTys instanceBindFun tpl_tys tys of + Just _ -> find ms (item:us) rest + Nothing -> find ms us rest + where + tpl_tv_set = mkVarSet tpl_tvs + +--------------- +-- This is the common way to call this function. +lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> InstEnvs -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult +-- ^ See Note [Rules for instance lookup] +-- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify +lookupInstEnv check_overlap_safe + (InstEnvs { ie_global = pkg_ie + , ie_local = home_ie + , ie_visible = vis_mods }) + cls + tys + = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ + (final_matches, final_unifs, unsafe_overlapped) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + final_matches = foldr insert_overlapping [] all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + unsafe_overlapped + = case final_matches of + [match] -> check_safe match + _ -> [] + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | isIncoherent (fst m) -> [] + _ -> all_unifs + + -- NOTE [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. + check_safe (inst,_) + = case check_overlap_safe && unsafeTopInstance inst of + -- make sure it only overlaps instances from the same module + True -> go [] all_matches + -- most specific is from a trusted location. + False -> [] + where + go bad [] = bad + go bad (i@(x,_):unchecked) = + if inSameMod x || isOverlappable x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + + -- We consider the most specific instance unsafe when it both: + -- (1) Comes from a module compiled as `Safe` + -- (2) Is an orphan instance, OR, an instance for a MPTC + unsafeTopInstance inst = isSafeOverlap (is_flag inst) && + (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) + +--------------- +insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_inst `can_override` old_inst + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_inst `can_override` new_inst + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | isIncoherent old_inst -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | isIncoherent new_inst -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items + where + + new_beats_old = new_inst `more_specific_than` old_inst + old_beats_new = old_inst `more_specific_than` new_inst + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + instA `more_specific_than` instB + = isJust (tcMatchTys (is_tys instB) (is_tys instA)) + + instA `can_override` instB + = isOverlapping instA || isOverlappable instB + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: #9242. + -- Previous change: #3877, Dec 10. + +{- +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some classes, the choice of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x -- Wanted: D Int Int + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + +Should this logic only work when *all* candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance [incoherent] [Int] b c + instance [incoherent] C a Int c +Thanks to the incoherent flags, + [Wanted] C [a] b Int +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are others. + + + +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +instanceBindFun :: TyCoVar -> BindFlag +instanceBindFun tv | isOverlappableTyVar tv = Skolem + | otherwise = BindMe + -- Note [Binding when looking up instances] + +{- +Note [Binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +The key_tys can contain skolem constants, and we can guarantee that those +are never going to be instantiated to anything, so we should not involve +them in the unification test. Example: + class Foo a where { op :: a -> Int } + instance Foo a => Foo [a] -- NB overlap + instance Foo [Int] -- NB overlap + data T = forall a. Foo a => MkT a + f :: T -> Int + f (MkT x) = op [x,x] +The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd +complain, saying that the choice of instance depended on the instantiation +of 'a'; but of course it isn't *going* to be instantiated. + +We do this only for isOverlappableTyVar skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a' +-} diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -56,36 +56,35 @@ import GhcPrelude -import Id -import Var ( EvVar, setTyVarUnique ) +import GHC.Types.Id +import GHC.Types.Var ( EvVar, setTyVarUnique ) import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) -import Literal +import GHC.Types.Literal import GHC.Driver.Types +import GHC.Platform import TysWiredIn import PrelNames -import GHC.Hs.Utils ( mkChunkified, chunkify ) -import Type -import Coercion ( isCoVar ) +import GHC.Hs.Utils ( mkChunkified, chunkify ) +import GHC.Core.Type +import GHC.Core.Coercion ( isCoVar ) +import GHC.Core.DataCon ( DataCon, dataConWorkId ) import TysPrim -import DataCon ( DataCon, dataConWorkId ) -import IdInfo -import Demand -import Cpr -import Name hiding ( varName ) +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name hiding ( varName ) import Outputable import FastString -import UniqSupply -import BasicTypes +import GHC.Types.Unique.Supply +import GHC.Types.Basic import Util -import GHC.Driver.Session import Data.List import Data.Char ( ord ) -import Control.Monad.Fail as MonadFail ( MonadFail ) infixl 4 `mkCoreApp`, `mkCoreApps` @@ -101,7 +100,7 @@ -- and then other Ids -- It is a deterministic sort, meaining it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] --- in Unique. +-- in GHC.Types.Unique. sortQuantVars vs = sorted_tcvs ++ ids where (tcvs, ids) = partition (isTyVar <||> isCoVar) vs @@ -193,7 +192,7 @@ -- that you expect to use only at a *binding* site. Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very -- easy to get into difficulties with shadowing. That's why it is used so little. --- See Note [WildCard binders] in SimplEnv +-- See Note [WildCard binders] in GHC.Core.Op.Simplify.Env mkWildValBinder :: Type -> Id mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors @@ -250,20 +249,20 @@ -} -- | 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 @@ -576,7 +575,7 @@ = FloatLet CoreBind | FloatCase CoreExpr Id AltCon [Var] -- case e of y { C ys -> ... } - -- See Note [Floating single-alternative cases] in SetLevels + -- See Note [Floating single-alternative cases] in GHC.Core.Op.SetLevels instance Outputable FloatBind where ppr (FloatLet b) = text "LET" <+> ppr b @@ -640,14 +639,14 @@ `App` list) -- | Make a 'build' expression applied to a locally-bound worker function -mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) +mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m) => Type -- ^ Type of list elements to be built -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's -- of the binders for the build worker function, returns -- the body of that worker -> m CoreExpr mkBuildExpr elt_ty mk_build_inside = do - [n_tyvar] <- newTyVars [alphaTyVar] + n_tyvar <- newTyVar alphaTyVar let n_ty = mkTyVarTy n_tyvar c_ty = mkVisFunTys [elt_ty, n_ty] n_ty [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] @@ -657,9 +656,9 @@ build_id <- lookupId buildName return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside where - newTyVars tyvar_tmpls = do - uniqs <- getUniquesM - return (zipWith setTyVarUnique tyvar_tmpls uniqs) + newTyVar tyvar_tmpl = do + uniq <- getUniqueM + return (setTyVarUnique tyvar_tmpl uniq) {- ************************************************************************ @@ -880,7 +879,7 @@ \x. case x of MkT a b -> g ($WMkT b a) where $WMkT is the wrapper for MkT that evaluates its arguments. We apply the same w/w split to this unfolding (see Note [Worker-wrapper -for INLINEABLE functions] in WorkWrap) so the template ends up like +for INLINEABLE functions] in GHC.Core.Op.WorkWrap) so the template ends up like \b. let a = absentError "blah" x = MkT a b in case x of MkT a b -> g ($WMkT b a) @@ -925,7 +924,7 @@ where absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for - -- lifted-type things; see Note [Absent errors] in WwLib + -- lifted-type things; see Note [Absent errors] in GHC.Core.Op.WorkWrap.Lib arity_info = vanillaIdInfo `setArityInfo` 1 -- NB: no bottoming strictness info, unlike other error-ids. -- See Note [aBSENT_ERROR_ID] diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs --- a/compiler/GHC/Core/Map.hs +++ b/compiler/GHC/Core/Map.hs @@ -41,18 +41,18 @@ import TrieMap import GHC.Core -import Coercion -import Name -import Type -import TyCoRep -import Var +import GHC.Core.Coercion +import GHC.Types.Name +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Types.Var import FastString(FastString) import Util import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import VarEnv -import NameEnv +import GHC.Types.Var.Env +import GHC.Types.Name.Env import Outputable import Control.Monad( (>=>) ) @@ -475,10 +475,10 @@ , tm_tylit :: TyLitMap a , tm_coerce :: Maybe a } - -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the --- last one? See Note [Equality on AppTys] in Type +-- last one? See Note [Equality on AppTys] in GHC.Core.Type -- -- Note, however, that we keep Constraint and Type apart here, despite the fact -- that they are both synonyms of TYPE 'LiftedRep (see #11715). @@ -515,7 +515,7 @@ (Just bv, Just bv') -> bv == bv' (Nothing, Nothing) -> v == v' _ -> False - -- See Note [Equality on AppTys] in Type + -- See Note [Equality on AppTys] in GHC.Core.Type (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s diff --git a/compiler/GHC/Core/Op/ConstantFold.hs b/compiler/GHC/Core/Op/ConstantFold.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Op/ConstantFold.hs @@ -0,0 +1,2254 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[ConFold]{Constant Folder} + +Conceptually, constant folding should be parameterized with the kind +of target machine to get identical behaviour during compilation time +and runtime. We cheat a little bit here... + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. +-} + +{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, + DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Op.ConstantFold + ( primOpRules + , builtinRules + , caseRules + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId ) + +import GHC.Core +import GHC.Core.Make +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Core.SimpleOpt ( exprIsLiteral_maybe ) +import PrimOp ( PrimOp(..), tagToEnumKey ) +import TysWiredIn +import TysPrim +import GHC.Core.TyCon + ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon + , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons + , tyConFamilySize ) +import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) +import GHC.Core.Utils ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType + , stripTicksTop, stripTicksTopT, mkTicks ) +import GHC.Core.Unfold ( exprIsConApp_maybe ) +import GHC.Core.Type +import GHC.Types.Name.Occurrence ( occNameFS ) +import PrelNames +import Maybes ( orElse ) +import GHC.Types.Name ( Name, nameOccName ) +import Outputable +import FastString +import GHC.Types.Basic +import GHC.Platform +import Util +import GHC.Core.Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) + +import Control.Applicative ( Alternative(..) ) + +import Control.Monad +import Data.Bits as Bits +import qualified Data.ByteString as BS +import Data.Int +import Data.Ratio +import Data.Word + +{- +Note [Constant folding] +~~~~~~~~~~~~~~~~~~~~~~~ +primOpRules generates a rewrite rule for each primop +These rules do what is often called "constant folding" +E.g. the rules for +# might say + 4 +# 5 = 9 +Well, of course you'd need a lot of rules if you did it +like that, so we use a BuiltinRule instead, so that we +can match in any two literal values. So the rule is really +more like + (Lit x) +# (Lit y) = Lit (x+#y) +where the (+#) on the rhs is done at compile time + +That is why these rules are built in here. +-} + +primOpRules :: Name -> PrimOp -> Maybe CoreRule +primOpRules nm = \case + TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] + DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ] + + -- Int operations + IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) + , identityPlatform zeroi + , numFoldingRules IntAddOp intPrimOps + ] + IntSubOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) + , rightIdentityPlatform zeroi + , equalArgs >> retLit zeroi + , numFoldingRules IntSubOp intPrimOps + ] + IntAddCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) + , identityCPlatform zeroi ] + IntSubCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) + , rightIdentityCPlatform zeroi + , equalArgs >> retLitNoC zeroi ] + IntMulOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) + , zeroElem zeroi + , identityPlatform onei + , numFoldingRules IntMulOp intPrimOps + ] + IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) + , leftZero zeroi + , rightIdentityPlatform onei + , equalArgs >> retLit onei ] + IntRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) + , leftZero zeroi + , do l <- getLiteral 1 + platform <- getPlatform + guard (l == onei platform) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] + AndIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] + OrIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityPlatform zeroi ] + XorIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityPlatform zeroi + , equalArgs >> retLit zeroi ] + NotIOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotIOp ] + IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp IntNegOp ] + ISllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) + , rightIdentityPlatform zeroi ] + ISraOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) + , rightIdentityPlatform zeroi ] + ISrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical + , rightIdentityPlatform zeroi ] + + -- Word operations + WordAddOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) + , identityPlatform zerow + , numFoldingRules WordAddOp wordPrimOps + ] + WordSubOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) + , rightIdentityPlatform zerow + , equalArgs >> retLit zerow + , numFoldingRules WordSubOp wordPrimOps + ] + WordAddCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) + , identityCPlatform zerow ] + WordSubCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) + , rightIdentityCPlatform zerow + , equalArgs >> retLitNoC zerow ] + WordMulOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) + , identityPlatform onew + , numFoldingRules WordMulOp wordPrimOps + ] + WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) + , rightIdentityPlatform onew ] + WordRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) + , leftZero zerow + , do l <- getLiteral 1 + platform <- getPlatform + guard (l == onew platform) + retLit zerow + , equalArgs >> retLit zerow ] + AndOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) + , idempotent + , zeroElem zerow ] + OrOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) + , idempotent + , identityPlatform zerow ] + XorOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) + , identityPlatform zerow + , equalArgs >> retLit zerow ] + NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotOp ] + SllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] + SrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] + + -- coercions + Word2IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit + , inversePrimOp Int2WordOp ] + Int2WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform int2WordLit + , inversePrimOp Word2IntOp ] + Narrow8IntOp -> mkPrimOpRule nm 1 [ liftLit narrow8IntLit + , subsumedByPrimOp Narrow8IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] + Narrow16IntOp -> mkPrimOpRule nm 1 [ liftLit narrow16IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] + Narrow32IntOp -> mkPrimOpRule nm 1 [ liftLit narrow32IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp + , removeOp32 + , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] + Narrow8WordOp -> mkPrimOpRule nm 1 [ liftLit narrow8WordLit + , subsumedByPrimOp Narrow8WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] + Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLit narrow16WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] + Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLit narrow32WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp + , removeOp32 + , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] + OrdOp -> mkPrimOpRule nm 1 [ liftLit char2IntLit + , inversePrimOp ChrOp ] + ChrOp -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit int2CharLit + , inversePrimOp OrdOp ] + Float2IntOp -> mkPrimOpRule nm 1 [ liftLit float2IntLit ] + Int2FloatOp -> mkPrimOpRule nm 1 [ liftLit int2FloatLit ] + Double2IntOp -> mkPrimOpRule nm 1 [ liftLit double2IntLit ] + Int2DoubleOp -> mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] + -- SUP: Not sure what the standard says about precision in the following 2 cases + Float2DoubleOp -> mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] + Double2FloatOp -> mkPrimOpRule nm 1 [ liftLit double2FloatLit ] + + -- Float + FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) + , identity zerof ] + FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) + , rightIdentity zerof ] + FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) + , identity onef + , strengthReduction twof FloatAddOp ] + -- zeroElem zerof doesn't hold because of NaN + FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) + , rightIdentity onef ] + FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp FloatNegOp ] + + -- Double + DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) + , identity zerod ] + DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) + , rightIdentity zerod ] + DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) + , identity oned + , strengthReduction twod DoubleAddOp ] + -- zeroElem zerod doesn't hold because of NaN + DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) + , rightIdentity oned ] + DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp DoubleNegOp ] + + -- Relational operators + + IntEqOp -> mkRelOpRule nm (==) [ litEq True ] + IntNeOp -> mkRelOpRule nm (/=) [ litEq False ] + CharEqOp -> mkRelOpRule nm (==) [ litEq True ] + CharNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + CharLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + FloatGtOp -> mkFloatingRelOpRule nm (>) + FloatGeOp -> mkFloatingRelOpRule nm (>=) + FloatLeOp -> mkFloatingRelOpRule nm (<=) + FloatLtOp -> mkFloatingRelOpRule nm (<) + FloatEqOp -> mkFloatingRelOpRule nm (==) + FloatNeOp -> mkFloatingRelOpRule nm (/=) + + DoubleGtOp -> mkFloatingRelOpRule nm (>) + DoubleGeOp -> mkFloatingRelOpRule nm (>=) + DoubleLeOp -> mkFloatingRelOpRule nm (<=) + DoubleLtOp -> mkFloatingRelOpRule nm (<) + DoubleEqOp -> mkFloatingRelOpRule nm (==) + DoubleNeOp -> mkFloatingRelOpRule nm (/=) + + WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + WordEqOp -> mkRelOpRule nm (==) [ litEq True ] + WordNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] + + SeqOp -> mkPrimOpRule nm 4 [ seqRule ] + SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] + + _ -> Nothing + +{- +************************************************************************ +* * +\subsection{Doing the business} +* * +************************************************************************ +-} + +-- useful shorthands +mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule +mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) + +mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> [RuleM CoreExpr] -> Maybe CoreRule +mkRelOpRule nm cmp extra + = mkPrimOpRule nm 2 $ + binaryCmpLit cmp : equal_rule : extra + where + -- x `cmp` x does not depend on x, so + -- compute it for the arbitrary value 'True' + -- and use that result + equal_rule = do { equalArgs + ; platform <- getPlatform + ; return (if cmp True True + then trueValInt platform + else falseValInt platform) } + +{- Note [Rules for floating-point comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need different rules for floating-point values because for floats +it is not true that x = x (for NaNs); so we do not want the equal_rule +rule that mkRelOpRule uses. + +Note also that, in the case of equality/inequality, we do /not/ +want to switch to a case-expression. For example, we do not want +to convert + case (eqFloat# x 3.8#) of + True -> this + False -> that +to + case x of + 3.8#::Float# -> this + _ -> that +See #9238. Reason: comparing floating-point values for equality +delicate, and we don't want to implement that delicacy in the code for +case expressions. So we make it an invariant of Core that a case +expression never scrutinises a Float# or Double#. + +This transformation is what the litEq rule does; +see Note [The litEq rule: converting equality to case]. +So we /refrain/ from using litEq for mkFloatingRelOpRule. +-} + +mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> Maybe CoreRule +-- See Note [Rules for floating-point comparisons] +mkFloatingRelOpRule nm cmp + = mkPrimOpRule nm 2 [binaryCmpLit cmp] + +-- common constants +zeroi, onei, zerow, onew :: Platform -> Literal +zeroi platform = mkLitInt platform 0 +onei platform = mkLitInt platform 1 +zerow platform = mkLitWord platform 0 +onew platform = mkLitWord platform 1 + +zerof, onef, twof, zerod, oned, twod :: Literal +zerof = mkLitFloat 0.0 +onef = mkLitFloat 1.0 +twof = mkLitFloat 2.0 +zerod = mkLitDouble 0.0 +oned = mkLitDouble 1.0 +twod = mkLitDouble 2.0 + +cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool) + -> Literal -> Literal -> Maybe CoreExpr +cmpOp platform cmp = go + where + done True = Just $ trueValInt platform + done False = Just $ falseValInt platform + + -- These compares are at different types + go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) + go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) + go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) + go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) + | nt1 /= nt2 = Nothing + | otherwise = done (i1 `cmp` i2) + go _ _ = Nothing + +-------------------------- + +negOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Negate +negOp env = \case + (LitFloat 0.0) -> Nothing -- can't represent -0.0 as a Rational + (LitFloat f) -> Just (mkFloatVal env (-f)) + (LitDouble 0.0) -> Nothing + (LitDouble d) -> Just (mkDoubleVal env (-d)) + (LitNumber nt i t) + | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i) t)) + _ -> Nothing + +complementOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Binary complement +complementOp env (LitNumber nt i t) = + Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i) t)) +complementOp _ _ = Nothing + +-------------------------- +intOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2 = intOp2' . const + +intOp2' :: (Integral a, Integral b) + => (RuleOpts -> a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2' op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = + let o = op env + in intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2) +intOp2' _ _ _ _ = Nothing -- Could find LitLit + +intOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOpC2 op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do + intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) +intOpC2 _ _ _ _ = Nothing -- Could find LitLit + +shiftRightLogical :: Platform -> Integer -> Int -> Integer +-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do +-- Do this by converting to Word and back. Obviously this won't work for big +-- values, but its ok as we use it here +shiftRightLogical platform x n = + case platformWordSize platform of + PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) + PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) + +-------------------------- +retLit :: (Platform -> Literal) -> RuleM CoreExpr +retLit l = do platform <- getPlatform + return $ Lit $ l platform + +retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr +retLitNoC l = do platform <- getPlatform + let lit = l platform + let ty = literalType lit + return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)] + +wordOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) + = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing -- Could find LitLit + +wordOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOpC2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = + wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) +wordOpC2 _ _ _ _ = Nothing -- Could find LitLit + +shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr +-- Shifts take an Int; hence third arg of op is Int +-- Used for shift primops +-- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# +-- SllOp, SrlOp :: Word# -> Int# -> Word# +shiftRule shift_op + = do { platform <- getPlatform + ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs + ; case e1 of + _ | shift_len == 0 + -> return e1 + -- See Note [Guarding against silly shifts] + | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform) + -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0 (exprType e1) + + -- Do the shift at type Integer, but shift length is Int + Lit (LitNumber nt x t) + | 0 < shift_len + , shift_len <= toInteger (platformWordSizeInBits platform) + -> let op = shift_op platform + y = x `op` fromInteger shift_len + in liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y t)) + + _ -> mzero } + +-------------------------- +floatOp2 :: (Rational -> Rational -> Rational) + -> RuleOpts -> Literal -> Literal + -> Maybe (Expr CoreBndr) +floatOp2 op env (LitFloat f1) (LitFloat f2) + = Just (mkFloatVal env (f1 `op` f2)) +floatOp2 _ _ _ _ = Nothing + +-------------------------- +doubleOp2 :: (Rational -> Rational -> Rational) + -> RuleOpts -> Literal -> Literal + -> Maybe (Expr CoreBndr) +doubleOp2 op env (LitDouble f1) (LitDouble f2) + = Just (mkDoubleVal env (f1 `op` f2)) +doubleOp2 _ _ _ _ = Nothing + +-------------------------- +{- Note [The litEq rule: converting equality to case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This stuff turns + n ==# 3# +into + case n of + 3# -> True + m -> False + +This is a Good Thing, because it allows case-of case things +to happen, and case-default absorption to happen. For +example: + + if (n ==# 3#) || (n ==# 4#) then e1 else e2 +will transform to + case n of + 3# -> e1 + 4# -> e1 + m -> e2 +(modulo the usual precautions to avoid duplicating e1) +-} + +litEq :: Bool -- True <=> equality, False <=> inequality + -> RuleM CoreExpr +litEq is_eq = msum + [ do [Lit lit, expr] <- getArgs + platform <- getPlatform + do_lit_eq platform lit expr + , do [expr, Lit lit] <- getArgs + platform <- getPlatform + do_lit_eq platform lit expr ] + where + do_lit_eq platform lit expr = do + guard (not (litIsLifted lit)) + return (mkWildCase expr (literalType lit) intPrimTy + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) + where + val_if_eq | is_eq = trueValInt platform + | otherwise = falseValInt platform + val_if_neq | is_eq = falseValInt platform + | otherwise = trueValInt platform + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Comparison -> RuleM CoreExpr +boundsCmp op = do + platform <- getPlatform + [a, b] <- getArgs + liftMaybe $ mkRuleFn platform op a b + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn _ _ _ _ = Nothing + +isMinBound :: Platform -> Literal -> Bool +isMinBound _ (LitChar c) = c == minBound +isMinBound platform (LitNumber nt i _) = case nt of + LitNumInt -> i == platformMinInt platform + LitNumInt64 -> i == toInteger (minBound :: Int64) + LitNumWord -> i == 0 + LitNumWord64 -> i == 0 + LitNumNatural -> i == 0 + LitNumInteger -> False +isMinBound _ _ = False + +isMaxBound :: Platform -> Literal -> Bool +isMaxBound _ (LitChar c) = c == maxBound +isMaxBound platform (LitNumber nt i _) = case nt of + LitNumInt -> i == platformMaxInt platform + LitNumInt64 -> i == toInteger (maxBound :: Int64) + LitNumWord -> i == platformMaxWord platform + LitNumWord64 -> i == toInteger (maxBound :: Word64) + LitNumNatural -> False + LitNumInteger -> False +isMaxBound _ _ = False + +-- | Create an Int literal expression while ensuring the given Integer is in the +-- target Int range +intResult :: Platform -> Integer -> Maybe CoreExpr +intResult platform result = Just (intResult' platform result) + +intResult' :: Platform -> Integer -> CoreExpr +intResult' platform result = Lit (mkLitIntWrap platform result) + +-- | Create an unboxed pair of an Int literal expression, ensuring the given +-- Integer is in the target Int range and the corresponding overflow flag +-- (@0#@/@1#@) if it wasn't. +intCResult :: Platform -> Integer -> Maybe CoreExpr +intCResult platform result = Just (mkPair [Lit lit, Lit c]) + where + mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] + (lit, b) = mkLitIntWrapC platform result + c = if b then onei platform else zeroi platform + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +wordResult :: Platform -> Integer -> Maybe CoreExpr +wordResult platform result = Just (wordResult' platform result) + +wordResult' :: Platform -> Integer -> CoreExpr +wordResult' platform result = Lit (mkLitWordWrap platform result) + +-- | Create an unboxed pair of a Word literal expression, ensuring the given +-- Integer is in the target Word range and the corresponding carry flag +-- (@0#@/@1#@) if it wasn't. +wordCResult :: Platform -> Integer -> Maybe CoreExpr +wordCResult platform result = Just (mkPair [Lit lit, Lit c]) + where + mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] + (lit, b) = mkLitWordWrapC platform result + c = if b then onei platform else zeroi platform + +inversePrimOp :: PrimOp -> RuleM CoreExpr +inversePrimOp primop = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId primop primop_id + return e + +subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr +this `subsumesPrimOp` that = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId that primop_id + return (Var (mkPrimOpId this) `App` e) + +subsumedByPrimOp :: PrimOp -> RuleM CoreExpr +subsumedByPrimOp primop = do + [e@(Var primop_id `App` _)] <- getArgs + matchPrimOpId primop primop_id + return e + +-- | narrow subsumes bitwise `and` with full mask (cf #16402): +-- +-- narrowN (x .&. m) +-- m .&. (2^N-1) = 2^N-1 +-- ==> narrowN x +-- +-- e.g. narrow16 (x .&. 0xFFFF) +-- ==> narrow16 x +-- +narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr +narrowSubsumesAnd and_primop narrw n = do + [Var primop_id `App` x `App` y] <- getArgs + matchPrimOpId and_primop primop_id + let mask = bit n -1 + g v (Lit (LitNumber _ m _)) = do + guard (m .&. mask == mask) + return (Var (mkPrimOpId narrw) `App` v) + g _ _ = mzero + g x y <|> g y x + +idempotent :: RuleM CoreExpr +idempotent = do [e1, e2] <- getArgs + guard $ cheapEqExpr e1 e2 + return e1 + +{- +Note [Guarding against silly shifts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + import Data.Bits( (.|.), shiftL ) + chunkToBitmap :: [Bool] -> Word32 + chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +This optimises to: +Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> + case w1_sCT of _ { + [] -> 0##; + : x_aAW xs_aAX -> + case x_aAW of _ { + GHC.Types.False -> + case w_sCS of wild2_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; + 9223372036854775807 -> 0## }; + GHC.Types.True -> + case GHC.Prim.>=# w_sCS 64 of _ { + GHC.Types.False -> + case w_sCS of wild3_Xh { + __DEFAULT -> + case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> + GHC.Prim.or# (GHC.Prim.narrow32Word# + (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) + ww_sCW + }; + 9223372036854775807 -> + GHC.Prim.narrow32Word# +!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) + }; + GHC.Types.True -> + case w_sCS of wild3_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; + 9223372036854775807 -> 0## + } } } } + +Note the massive shift on line "!!!!". It can't happen, because we've checked +that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! +Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we +can't constant fold it, but if it gets to the assembler we get + Error: operand type mismatch for `shl' + +So the best thing to do is to rewrite the shift with a call to error, +when the second arg is large. However, in general we cannot do this; consider +this case + + let x = I# (uncheckedIShiftL# n 80) + in ... + +Here x contains an invalid shift and consequently we would like to rewrite it +as follows: + + let x = I# (error "invalid shift) + in ... + +This was originally done in the fix to #16449 but this breaks the let/app +invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742. +For the reasons discussed in Note [Checking versus non-checking primops] (in +the PrimOp module) there is no safe way rewrite the argument of I# such that +it bottoms. + +Consequently we instead take advantage of the fact that large shifts are +undefined behavior (see associated documentation in primops.txt.pp) and +transform the invalid shift into an "obviously incorrect" value. + +There are two cases: + +- Shifting fixed-width things: the primops ISll, Sll, etc + These are handled by shiftRule. + + We are happy to shift by any amount up to wordSize but no more. + +- Shifting Integers: the function shiftLInteger, shiftRInteger + from the 'integer' library. These are handled by rule_shift_op, + and match_Integer_shift_op. + + Here we could in principle shift by any amount, but we arbitrary + limit the shift to 4 bits; in particular we do not want shift by a + huge amount, which can happen in code like that above. + +The two cases are more different in their code paths that is comfortable, +but that is only a historical accident. + + +************************************************************************ +* * +\subsection{Vaguely generic functions} +* * +************************************************************************ +-} + +mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +-- Gives the Rule the same name as the primop itself +mkBasicRule op_name n_args rm + = BuiltinRule { ru_name = occNameFS (nameOccName op_name), + ru_fn = op_name, + ru_nargs = n_args, + ru_try = runRuleM rm } + +newtype RuleM r = RuleM + { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } + deriving (Functor) + +instance Applicative RuleM where + pure x = RuleM $ \_ _ _ _ -> Just x + (<*>) = ap + +instance Monad RuleM where + RuleM f >>= g + = RuleM $ \env iu fn args -> + case f env iu fn args of + Nothing -> Nothing + Just r -> runRuleM (g r) env iu fn args + +instance MonadFail RuleM where + fail _ = mzero + +instance Alternative RuleM where + empty = RuleM $ \_ _ _ _ -> Nothing + RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args -> + f1 env iu fn args <|> f2 env iu fn args + +instance MonadPlus RuleM + +getPlatform :: RuleM Platform +getPlatform = roPlatform <$> getEnv + +getEnv :: RuleM RuleOpts +getEnv = RuleM $ \env _ _ _ -> Just env + +liftMaybe :: Maybe a -> RuleM a +liftMaybe Nothing = mzero +liftMaybe (Just x) = return x + +liftLit :: (Literal -> Literal) -> RuleM CoreExpr +liftLit f = liftLitPlatform (const f) + +liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr +liftLitPlatform f = do + platform <- getPlatform + [Lit lit] <- getArgs + return $ Lit (f platform lit) + +removeOp32 :: RuleM CoreExpr +removeOp32 = do + platform <- getPlatform + case platformWordSize platform of + PW4 -> do + [e] <- getArgs + return e + PW8 -> + mzero + +getArgs :: RuleM [CoreExpr] +getArgs = RuleM $ \_ _ _ args -> Just args + +getInScopeEnv :: RuleM InScopeEnv +getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu + +getFunction :: RuleM Id +getFunction = RuleM $ \_ _ fn _ -> Just fn + +-- return the n-th argument of this rule, if it is a literal +-- argument indices start from 0 +getLiteral :: Int -> RuleM Literal +getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of + (Lit l:_) -> Just l + _ -> Nothing + +unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit op = do + env <- getEnv + [Lit l] <- getArgs + liftMaybe $ op env (convFloating env l) + +binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit op = do + env <- getEnv + [Lit l1, Lit l2] <- getArgs + liftMaybe $ op env (convFloating env l1) (convFloating env l2) + +binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr +binaryCmpLit op = do + platform <- getPlatform + binaryLit (\_ -> cmpOp platform op) + +leftIdentity :: Literal -> RuleM CoreExpr +leftIdentity id_lit = leftIdentityPlatform (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityPlatform (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityPlatform id_lit = do + platform <- getPlatform + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit platform + return e2 + +-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in +-- addition to the result, we have to indicate that no carry/overflow occurred. +leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityCPlatform id_lit = do + platform <- getPlatform + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit platform + let no_c = Lit (zeroi platform) + return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) + +rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityPlatform id_lit = do + platform <- getPlatform + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit platform + return e1 + +-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in +-- addition to the result, we have to indicate that no carry/overflow occurred. +rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityCPlatform id_lit = do + platform <- getPlatform + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit platform + let no_c = Lit (zeroi platform) + return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) + +identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityPlatform lit = + leftIdentityPlatform lit `mplus` rightIdentityPlatform lit + +-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition +-- to the result, we have to indicate that no carry/overflow occurred. +identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityCPlatform lit = + leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit + +leftZero :: (Platform -> Literal) -> RuleM CoreExpr +leftZero zero = do + platform <- getPlatform + [Lit l1, _] <- getArgs + guard $ l1 == zero platform + return $ Lit l1 + +rightZero :: (Platform -> Literal) -> RuleM CoreExpr +rightZero zero = do + platform <- getPlatform + [_, Lit l2] <- getArgs + guard $ l2 == zero platform + return $ Lit l2 + +zeroElem :: (Platform -> Literal) -> RuleM CoreExpr +zeroElem lit = leftZero lit `mplus` rightZero lit + +equalArgs :: RuleM () +equalArgs = do + [e1, e2] <- getArgs + guard $ e1 `cheapEqExpr` e2 + +nonZeroLit :: Int -> RuleM () +nonZeroLit n = getLiteral n >>= guard . not . isZeroLit + +-- When excess precision is not requested, cut down the precision of the +-- Rational value to that of Float/Double. We confuse host architecture +-- and target architecture here, but it's convenient (and wrong :-). +convFloating :: RuleOpts -> Literal -> Literal +convFloating env (LitFloat f) | not (roExcessRationalPrecision env) = + LitFloat (toRational (fromRational f :: Float )) +convFloating env (LitDouble d) | not (roExcessRationalPrecision env) = + LitDouble (toRational (fromRational d :: Double)) +convFloating _ l = l + +guardFloatDiv :: RuleM () +guardFloatDiv = do + [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs + guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + +guardDoubleDiv :: RuleM () +guardDoubleDiv = do + [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs + guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] + && d2 /= 0 -- avoid NaN and Infinity/-Infinity +-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to +-- zero, but we might want to preserve the negative zero here which +-- is representable in Float/Double but not in (normalised) +-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? + +strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr +strengthReduction two_lit add_op = do -- Note [Strength reduction] + arg <- msum [ do [arg, Lit mult_lit] <- getArgs + guard (mult_lit == two_lit) + return arg + , do [Lit mult_lit, arg] <- getArgs + guard (mult_lit == two_lit) + return arg ] + return $ Var (mkPrimOpId add_op) `App` arg `App` arg + +-- Note [Strength reduction] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This rule turns floating point multiplications of the form 2.0 * x and +-- x * 2.0 into x + x addition, because addition costs less than multiplication. +-- See #7116 + +-- Note [What's true and false] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- trueValInt and falseValInt represent true and false values returned by +-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. +-- True is represented as an unboxed 1# literal, while false is represented +-- as 0# literal. +-- We still need Bool data constructors (True and False) to use in a rule +-- for constant folding of equal Strings + +trueValInt, falseValInt :: Platform -> Expr CoreBndr +trueValInt platform = Lit $ onei platform -- see Note [What's true and false] +falseValInt platform = Lit $ zeroi platform + +trueValBool, falseValBool :: Expr CoreBndr +trueValBool = Var trueDataConId -- see Note [What's true and false] +falseValBool = Var falseDataConId + +ltVal, eqVal, gtVal :: Expr CoreBndr +ltVal = Var ordLTDataConId +eqVal = Var ordEQDataConId +gtVal = Var ordGTDataConId + +mkIntVal :: Platform -> Integer -> Expr CoreBndr +mkIntVal platform i = Lit (mkLitInt platform i) +mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr +mkFloatVal env f = Lit (convFloating env (LitFloat f)) +mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr +mkDoubleVal env d = Lit (convFloating env (LitDouble d)) + +matchPrimOpId :: PrimOp -> Id -> RuleM () +matchPrimOpId op id = do + op' <- liftMaybe $ isPrimOpId_maybe id + guard $ op == op' + +{- +************************************************************************ +* * +\subsection{Special rules for seq, tagToEnum, dataToTag} +* * +************************************************************************ + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +We used to make this check in the type inference engine, but it's quite +ugly to do so, because the delayed constraint solving means that we don't +really know what's going on until the end. It's very much a corner case +because we don't expect the user to call tagToEnum# at all; we merely +generate calls in derived instances of Enum. So we compromise: a +rewrite rule rewrites a bad instance of tagToEnum# to an error call, +and emits a warning. +-} + +tagToEnumRule :: RuleM CoreExpr +-- If data T a = A | B | C +-- then tagToEnum# (T ty) 2# --> B ty +tagToEnumRule = do + [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs + case splitTyConApp_maybe ty of + Just (tycon, tc_args) | isEnumerationTyCon tycon -> do + let tag = fromInteger i + correct_tag dc = (dataConTagZ dc) == tag + (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) + ASSERT(null rest) return () + return $ mkTyApps (Var (dataConWorkId dc)) tc_args + + -- See Note [tagToEnum#] + _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) + return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" + +------------------------------ +dataToTagRule :: RuleM CoreExpr +-- See Note [dataToTag#] in primops.txt.pp +dataToTagRule = a `mplus` b + where + -- dataToTag (tagToEnum x) ==> x + a = do + [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs + guard $ tag_to_enum `hasKey` tagToEnumKey + guard $ ty1 `eqType` ty2 + return tag + + -- dataToTag (K e1 e2) ==> tag-of K + -- This also works (via exprIsConApp_maybe) for + -- dataToTag x + -- where x's unfolding is a constructor application + b = do + dflags <- getPlatform + [_, val_arg] <- getArgs + in_scope <- getInScopeEnv + (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg + ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () + return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) + +{- Note [dataToTag# magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The primop dataToTag# is unusual because it evaluates its argument. +Only `SeqOp` shares that property. (Other primops do not do anything +as fancy as argument evaluation.) The special handling for dataToTag# +is: + +* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp, + (actually in app_ok). Most primops with lifted arguments do not + evaluate those arguments, but DataToTagOp and SeqOp are two + exceptions. We say that they are /never/ ok-for-speculation, + regardless of the evaluated-ness of their argument. + See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp] + +* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr, + that evaluates its argument and then extracts the tag from + the returned value. + +* An application like (dataToTag# (Just x)) is optimised by + dataToTagRule in GHC.Core.Op.ConstantFold. + +* A case expression like + case (dataToTag# e) of + gets transformed t + case e of + by GHC.Core.Op.ConstantFold.caseRules; see Note [caseRules for dataToTag] + +See #15696 for a long saga. +-} + +{- ********************************************************************* +* * + unsafeEqualityProof +* * +********************************************************************* -} + +-- unsafeEqualityProof k t t ==> UnsafeRefl (Refl t) +-- That is, if the two types are equal, it's not unsafe! + +unsafeEqualityProofRule :: RuleM CoreExpr +unsafeEqualityProofRule + = do { [Type rep, Type t1, Type t2] <- getArgs + ; guard (t1 `eqType` t2) + ; fn <- getFunction + ; let (_, ue) = splitForAllTys (idType fn) + tc = tyConAppTyCon ue -- tycon: UnsafeEquality + (dc:_) = tyConDataCons tc -- data con: UnsafeRefl + -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r). + -- UnsafeEquality r a a + ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) } + + +{- ********************************************************************* +* * + Rules for seq# and spark# +* * +********************************************************************* -} + +{- Note [seq# magic] +~~~~~~~~~~~~~~~~~~~~ +The primop + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is /not/ the same as the Prelude function seq :: a -> b -> b +as you can see from its type. In fact, seq# is the implementation +mechanism for 'evaluate' + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +The semantics of seq# is + * evaluate its first argument + * and return it + +Things to note + +* Why do we need a primop at all? That is, instead of + case seq# x s of (# x, s #) -> blah + why not instead say this? + case x of { DEFAULT -> blah) + + Reason (see #5129): if we saw + catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler + + then we'd drop the 'case x' because the body of the case is bottom + anyway. But we don't want to do that; the whole /point/ of + seq#/evaluate is to evaluate 'x' first in the IO monad. + + In short, we /always/ evaluate the first argument and never + just discard it. + +* Why return the value? So that we can control sharing of seq'd + values: in + let x = e in x `seq` ... x ... + We don't want to inline x, so better to represent it as + let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + also it matches the type of rseq in the Eval monad. + +Implementing seq#. The compiler has magic for SeqOp in + +- GHC.Core.Op.ConstantFold.seqRule: eliminate (seq# s) + +- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# + +- GHC.Core.Utils.exprOkForSpeculation; + see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils + +- Simplify.addEvals records evaluated-ness for the result; see + Note [Adding evaluatedness info to pattern-bound variables] + in GHC.Core.Op.Simplify +-} + +seqRule :: RuleM CoreExpr +seqRule = do + [Type ty_a, Type _ty_s, a, s] <- getArgs + guard $ exprIsHNF a + return $ mkCoreUbxTup [exprType s, ty_a] [s, a] + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: RuleM CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? + +{- +************************************************************************ +* * +\subsection{Built in rules} +* * +************************************************************************ + +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in rule, there's a danger +that we'll see + + f = ...(eq String x).... + + ....and lower down... + + eqString = ... + +Then a rewrite would give + + f = ...(eqString x)... + ....and lower down... + eqString = ... + +and lo, eqString is not in scope. This only really matters when we +get to code generation. But the occurrence analyser does a GlomBinds +step when necessary, that does a new SCC analysis on the whole set of +bindings (see occurAnalysePgm), which sorts out the dependency, so all +is fine. +-} + +builtinRules :: [CoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma +builtinRules + = [BuiltinRule { ru_name = fsLit "AppendLitString", + ru_fn = unpackCStringFoldrName, + ru_nargs = 4, ru_try = match_append_lit }, + BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, + ru_nargs = 2, ru_try = match_eq_string }, + BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, + ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, + BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, + ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, + + mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, + + mkBasicRule divIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero zeroi + , do + [arg, Lit (LitNumber LitNumInt d _)] <- getArgs + Just n <- return $ exactLog2 d + platform <- getPlatform + return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal platform n + ], + + mkBasicRule modIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero zeroi + , do + [arg, Lit (LitNumber LitNumInt d _)] <- getArgs + Just _ <- return $ exactLog2 d + platform <- getPlatform + return $ Var (mkPrimOpId AndIOp) + `App` arg `App` mkIntVal platform (d - 1) + ] + ] + ++ builtinIntegerRules + ++ builtinNaturalRules +{-# NOINLINE builtinRules #-} +-- there is no benefit to inlining these yet, despite this, GHC produces +-- unfoldings for this regardless since the floated list entries look small. + +builtinIntegerRules :: [CoreRule] +builtinIntegerRules = + [rule_IntToInteger "smallInteger" smallIntegerName, + rule_WordToInteger "wordToInteger" wordToIntegerName, + rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, + rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, + rule_convert "integerToWord" integerToWordName mkWordLitWord, + rule_convert "integerToInt" integerToIntName mkIntLitInt, + rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), + rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), + rule_binop "plusInteger" plusIntegerName (+), + rule_binop "minusInteger" minusIntegerName (-), + rule_binop "timesInteger" timesIntegerName (*), + rule_unop "negateInteger" negateIntegerName negate, + rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), + rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), + rule_unop "absInteger" absIntegerName abs, + rule_unop "signumInteger" signumIntegerName signum, + rule_binop_Prim "leInteger#" leIntegerPrimName (<=), + rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), + rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), + rule_binop_Prim "geInteger#" geIntegerPrimName (>=), + rule_binop_Ordering "compareInteger" compareIntegerName compare, + rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), + rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, + rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, + rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), + rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, + rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, + rule_binop "gcdInteger" gcdIntegerName gcd, + rule_binop "lcmInteger" lcmIntegerName lcm, + rule_binop "andInteger" andIntegerName (.&.), + rule_binop "orInteger" orIntegerName (.|.), + rule_binop "xorInteger" xorIntegerName xor, + rule_unop "complementInteger" complementIntegerName complement, + rule_shift_op "shiftLInteger" shiftLIntegerName shiftL, + rule_shift_op "shiftRInteger" shiftRIntegerName shiftR, + rule_bitInteger "bitInteger" bitIntegerName, + -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_divop_one "divInteger" divIntegerName div, + rule_divop_one "modInteger" modIntegerName mod, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, + -- These rules below don't actually have to be built in, but if we + -- put them in the Haskell source then we'd have to duplicate them + -- between all Integer implementations + rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, + rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, + rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, + rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, + rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, + rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, + rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp + ] + where rule_convert str name convert + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_convert convert } + rule_IntToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_IntToInteger } + rule_WordToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_WordToInteger } + rule_Int64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Int64ToInteger } + rule_Word64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Word64ToInteger } + rule_unop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_unop op } + rule_bitInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_bitInteger } + rule_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop op } + rule_divop_both str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_both op } + rule_divop_one str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_one op } + rule_shift_op str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_shift_op op } + rule_binop_Prim str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Prim op } + rule_binop_Ordering str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Ordering op } + rule_encodeFloat str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_encodeFloat op } + rule_decodeDouble str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_decodeDouble } + rule_XToIntegerToX str name toIntegerName + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_XToIntegerToX toIntegerName } + rule_smallIntegerTo str name primOp + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_smallIntegerTo primOp } + rule_rationalTo str name mkLit + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_rationalTo mkLit } + +builtinNaturalRules :: [CoreRule] +builtinNaturalRules = + [rule_binop "plusNatural" plusNaturalName (+) + ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing) + ,rule_binop "timesNatural" timesNaturalName (*) + ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName + ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName + ,rule_WordToNatural "wordToNatural" wordToNaturalName + ] + where rule_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Natural_binop op } + rule_partial_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Natural_partial_binop op } + rule_NaturalToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_NaturalToInteger } + rule_NaturalFromInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_NaturalFromInteger } + rule_WordToNatural str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_WordToNatural } + +--------------------------------------------------- +-- The rule is this: +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) +-- = unpackFoldrCString# "foobaz" c n + +match_append_lit :: RuleFun +match_append_lit _ id_unf _ + [ Type ty1 + , lit1 + , c1 + , e2 + ] + -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the + -- `lit` and `c` arguments, lest this may fail to fire when building with + -- -g3. See #16740. + | (strTicks, Var unpk `App` Type ty2 + `App` lit2 + `App` c2 + `App` n) <- stripTicksTop tickishFloatable e2 + , unpk `hasKey` unpackCStringFoldrIdKey + , cheapEqExpr' tickishFloatable c1 c2 + , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 + , c2Ticks <- stripTicksTopT tickishFloatable c2 + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + = ASSERT( ty1 `eqType` ty2 ) + Just $ mkTicks strTicks + $ Var unpk `App` Type ty1 + `App` Lit (LitString (s1 `BS.append` s2)) + `App` mkTicks (c1Ticks ++ c2Ticks) c1' + `App` n + +match_append_lit _ _ _ _ = Nothing + +--------------------------------------------------- +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 + +match_eq_string :: RuleFun +match_eq_string _ id_unf _ + [Var unpk1 `App` lit1, Var unpk2 `App` lit2] + | unpk1 `hasKey` unpackCStringIdKey + , unpk2 `hasKey` unpackCStringIdKey + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + = Just (if s1 == s2 then trueValBool else falseValBool) + +match_eq_string _ _ _ _ = Nothing + + +--------------------------------------------------- +-- The rule is this: +-- inline f_ty (f a b c) = a b c +-- (if f has an unfolding, EVEN if it's a loop breaker) +-- +-- It's important to allow the argument to 'inline' to have args itself +-- (a) because its more forgiving to allow the programmer to write +-- inline f a b c +-- or inline (f a b c) +-- (b) because a polymorphic f wll get a type argument that the +-- programmer can't avoid +-- +-- Also, don't forget about 'inline's type argument! +match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline (Type _ : e : _) + | (Var f, args1) <- collectArgs e, + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! + = Just (mkApps unf args1) + +match_inline _ = Nothing + + +-- See Note [magicDictId magic] in `basicTypes/MkId.hs` +-- for a description of what is going on here. +match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] + | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap + , Just (dictTy, _) <- splitFunTy_maybe fieldTy + , Just dictTc <- tyConAppTyCon_maybe dictTy + , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc + = Just + $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) + `App` y + +match_magicDict _ = Nothing + +------------------------------------------------- +-- Integer rules +-- smallInteger (79::Int#) = 79::Integer +-- wordToInteger (79::Word#) = 79::Integer +-- Similarly Int64, Word64 + +match_IntToInteger :: RuleFun +match_IntToInteger = match_IntToInteger_unop id + +match_WordToInteger :: RuleFun +match_WordToInteger _ id_unf id [xl] + | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> + Just (Lit (mkLitInteger x integerTy)) + _ -> + panic "match_WordToInteger: Id has the wrong type" +match_WordToInteger _ _ _ _ = Nothing + +match_Int64ToInteger :: RuleFun +match_Int64ToInteger _ id_unf id [xl] + | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> + Just (Lit (mkLitInteger x integerTy)) + _ -> + panic "match_Int64ToInteger: Id has the wrong type" +match_Int64ToInteger _ _ _ _ = Nothing + +match_Word64ToInteger :: RuleFun +match_Word64ToInteger _ id_unf id [xl] + | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> + Just (Lit (mkLitInteger x integerTy)) + _ -> + panic "match_Word64ToInteger: Id has the wrong type" +match_Word64ToInteger _ _ _ _ = Nothing + +match_NaturalToInteger :: RuleFun +match_NaturalToInteger _ id_unf id [xl] + | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, naturalTy) -> + Just (Lit (LitNumber LitNumInteger x naturalTy)) + _ -> + panic "match_NaturalToInteger: Id has the wrong type" +match_NaturalToInteger _ _ _ _ = Nothing + +match_NaturalFromInteger :: RuleFun +match_NaturalFromInteger _ id_unf id [xl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , x >= 0 + = case splitFunTy_maybe (idType id) of + Just (_, naturalTy) -> + Just (Lit (LitNumber LitNumNatural x naturalTy)) + _ -> + panic "match_NaturalFromInteger: Id has the wrong type" +match_NaturalFromInteger _ _ _ _ = Nothing + +match_WordToNatural :: RuleFun +match_WordToNatural _ id_unf id [xl] + | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, naturalTy) -> + Just (Lit (LitNumber LitNumNatural x naturalTy)) + _ -> + panic "match_WordToNatural: Id has the wrong type" +match_WordToNatural _ _ _ _ = Nothing + +------------------------------------------------- +{- Note [Rewriting bitInteger] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For most types the bitInteger operation can be implemented in terms of shifts. +The integer-gmp package, however, can do substantially better than this if +allowed to provide its own implementation. However, in so doing it previously lost +constant-folding (see #8832). The bitInteger rule above provides constant folding +specifically for this function. + +There is, however, a bit of trickiness here when it comes to ranges. While the +AST encodes all integers as Integers, `bit` expects the bit +index to be given as an Int. Hence we coerce to an Int in the rule definition. +This will behave a bit funny for constants larger than the word size, but the user +should expect some funniness given that they will have at very least ignored a +warning in this case. +-} + +match_bitInteger :: RuleFun +-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer +match_bitInteger env id_unf fn [arg] + | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg + , x >= 0 + , x <= (toInteger (platformWordSizeInBits (roPlatform env)) - 1) + -- Make sure x is small enough to yield a decently small integer + -- Attempting to construct the Integer for + -- (bitInteger 9223372036854775807#) + -- would be a bad idea (#14959) + , let x_int = fromIntegral x :: Int + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) + -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) + _ -> panic "match_IntToInteger_unop: Id has the wrong type" + +match_bitInteger _ _ _ _ = Nothing + + +------------------------------------------------- +match_Integer_convert :: Num a + => (Platform -> a -> Expr CoreBndr) + -> RuleFun +match_Integer_convert convert env id_unf _ [xl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + = Just (convert (roPlatform env) (fromInteger x)) +match_Integer_convert _ _ _ _ _ = Nothing + +match_Integer_unop :: (Integer -> Integer) -> RuleFun +match_Integer_unop unop _ id_unf _ [xl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + = Just (Lit (LitNumber LitNumInteger (unop x) i)) +match_Integer_unop _ _ _ _ _ = Nothing + +match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun +match_IntToInteger_unop unop _ id_unf fn [xl] + | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) -> + Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) + _ -> + panic "match_IntToInteger_unop: Id has the wrong type" +match_IntToInteger_unop _ _ _ _ _ = Nothing + +match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_binop binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just (Lit (mkLitInteger (x `binop` y) i)) +match_Integer_binop _ _ _ _ _ = Nothing + +match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun +match_Natural_binop binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl + = Just (Lit (mkLitNatural (x `binop` y) i)) +match_Natural_binop _ _ _ _ _ = Nothing + +match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun +match_Natural_partial_binop binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl + , Just z <- x `binop` y + = Just (Lit (mkLitNatural z i)) +match_Natural_partial_binop _ _ _ _ _ = Nothing + +-- This helper is used for the quotRem and divMod functions +match_Integer_divop_both + :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun +match_Integer_divop_both divop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + , (r,s) <- x `divop` y + = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] +match_Integer_divop_both _ _ _ _ _ = Nothing + +-- This helper is used for the quot and rem functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_divop_one divop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (Lit (mkLitInteger (x `divop` y) i)) +match_Integer_divop_one _ _ _ _ _ = Nothing + +match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun +-- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer +-- See Note [Guarding against silly shifts] +match_Integer_shift_op binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl + , y >= 0 + , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat + -- arbitrary. We can get huge shifts in inaccessible code + -- (#15673) + = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i)) +match_Integer_shift_op _ _ _ _ _ = Nothing + +match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun +match_Integer_binop_Prim binop env id_unf _ [xl, yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just (if x `binop` y then trueValInt (roPlatform env) else falseValInt (roPlatform env)) +match_Integer_binop_Prim _ _ _ _ _ = Nothing + +match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun +match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just $ case x `binop` y of + LT -> ltVal + EQ -> eqVal + GT -> gtVal +match_Integer_binop_Ordering _ _ _ _ _ = Nothing + +match_Integer_Int_encodeFloat :: RealFloat a + => (a -> Expr CoreBndr) + -> RuleFun +match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl + = Just (mkLit $ encodeFloat x (fromInteger y)) +match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing + +--------------------------------------------------- +-- constant folding for Float/Double +-- +-- This turns +-- rationalToFloat n d +-- into a literal Float, and similarly for Doubles. +-- +-- it's important to not match d == 0, because that may represent a +-- literal "0/0" or similar, and we can't produce a literal value for +-- NaN or +-Inf +match_rationalTo :: RealFloat a + => (a -> Expr CoreBndr) + -> RuleFun +match_rationalTo mkLit _ id_unf _ [xl, yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (mkLit (fromRational (x % y))) +match_rationalTo _ _ _ _ _ = Nothing + +match_decodeDouble :: RuleFun +match_decodeDouble env id_unf fn [xl] + | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType fn) of + Just (_, res) + | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res + -> case decodeFloat (fromRational x :: Double) of + (y, z) -> + Just $ mkCoreUbxTup [integerTy, intHashTy] + [Lit (mkLitInteger y integerTy), + Lit (mkLitInt (roPlatform env) (toInteger z))] + _ -> + pprPanic "match_decodeDouble: Id has the wrong type" + (ppr fn <+> dcolon <+> ppr (idType fn)) +match_decodeDouble _ _ _ _ = Nothing + +match_XToIntegerToX :: Name -> RuleFun +match_XToIntegerToX n _ _ _ [App (Var x) y] + | idName x == n + = Just y +match_XToIntegerToX _ _ _ _ _ = Nothing + +match_smallIntegerTo :: PrimOp -> RuleFun +match_smallIntegerTo primOp _ _ _ [App (Var x) y] + | idName x == smallIntegerName + = Just $ App (Var (mkPrimOpId primOp)) y +match_smallIntegerTo _ _ _ _ _ = Nothing + + + +-------------------------------------------------------- +-- Note [Constant folding through nested expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We use rewrites rules to perform constant folding. It means that we don't +-- have a global view of the expression we are trying to optimise. As a +-- consequence we only perform local (small-step) transformations that either: +-- 1) reduce the number of operations +-- 2) rearrange the expression to increase the odds that other rules will +-- match +-- +-- We don't try to handle more complex expression optimisation cases that would +-- require a global view. For example, rewriting expressions to increase +-- sharing (e.g., Horner's method); optimisations that require local +-- transformations increasing the number of operations; rearrangements to +-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). +-- +-- We already have rules to perform constant folding on expressions with the +-- following shape (where a and/or b are literals): +-- +-- D) op +-- /\ +-- / \ +-- / \ +-- a b +-- +-- To support nested expressions, we match three other shapes of expression +-- trees: +-- +-- A) op1 B) op1 C) op1 +-- /\ /\ /\ +-- / \ / \ / \ +-- / \ / \ / \ +-- a op2 op2 c op2 op3 +-- /\ /\ /\ /\ +-- / \ / \ / \ / \ +-- b c a b a b c d +-- +-- +-- R1) +/- simplification: +-- ops = + or -, two literals (not siblings) +-- +-- Examples: +-- A: 5 + (10-x) ==> 15-x +-- B: (10+x) + 5 ==> 15+x +-- C: (5+a)-(5-b) ==> 0+(a+b) +-- +-- R2) * simplification +-- ops = *, two literals (not siblings) +-- +-- Examples: +-- A: 5 * (10*x) ==> 50*x +-- B: (10*x) * 5 ==> 50*x +-- C: (5*a)*(5*b) ==> 25*(a*b) +-- +-- R3) * distribution over +/- +-- op1 = *, op2 = + or -, two literals (not siblings) +-- +-- This transformation doesn't reduce the number of operations but switches +-- the outer and the inner operations so that the outer is (+) or (-) instead +-- of (*). It increases the odds that other rules will match after this one. +-- +-- Examples: +-- A: 5 * (10-x) ==> 50 - (5*x) +-- B: (10+x) * 5 ==> 50 + (5*x) +-- C: Not supported as it would increase the number of operations: +-- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b +-- +-- R4) Simple factorization +-- +-- op1 = + or -, op2/op3 = *, +-- one literal for each innermost * operation (except in the D case), +-- the two other terms are equals +-- +-- Examples: +-- A: x - (10*x) ==> (-9)*x +-- B: (10*x) + x ==> 11*x +-- C: (5*x)-(x*3) ==> 2*x +-- D: x+x ==> 2*x +-- +-- R5) +/- propagation +-- +-- ops = + or -, one literal +-- +-- This transformation doesn't reduce the number of operations but propagates +-- the constant to the outer level. It increases the odds that other rules +-- will match after this one. +-- +-- Examples: +-- A: x - (10-y) ==> (x+y) - 10 +-- B: (10+x) - y ==> 10 + (x-y) +-- C: N/A (caught by the A and B cases) +-- +-------------------------------------------------------- + +-- | Rules to perform constant folding into nested expressions +-- +--See Note [Constant folding through nested expressions] +numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr +numFoldingRules op dict = do + env <- getEnv + if not (roNumConstantFolding env) + then mzero + else do + [e1,e2] <- getArgs + platform <- getPlatform + let PrimOps{..} = dict platform + case BinOpApp e1 op e2 of + -- R1) +/- simplification + x :++: (y :++: v) -> return $ mkL (x+y) `add` v + x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v + x :++: (v :-: L y) -> return $ mkL (x-y) `add` v + L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v + L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v + L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v + + (y :++: v) :-: L x -> return $ mkL (y-x) `add` v + (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v + (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v + + (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) + (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) + (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v) + (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v) + (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w) + (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) + (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) + (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v) + (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w) + + (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w) + (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w) + (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w) + (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v) + (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) + (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) + (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) + (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) + (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) + + -- R2) * simplification + x :**: (y :**: v) -> return $ mkL (x*y) `mul` v + (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) + + -- R3) * distribution over +/- + x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v) + x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v) + x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y) + + -- R4) Simple factorization + v :+: w + | w `cheapEqExpr` v -> return $ mkL 2 `mul` v + w :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v + w :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v + (y :**: v) :+: w + | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v + (y :**: v) :-: w + | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v + (x :**: w) :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v + (x :**: w) :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v + + -- R5) +/- propagation + w :+: (y :++: v) -> return $ mkL y `add` (w `add` v) + (y :++: v) :+: w -> return $ mkL y `add` (w `add` v) + w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y + (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w) + w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y + (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v) + w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v) + w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y + (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v) + (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y + + _ -> mzero + + + +-- | Match the application of a binary primop +pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr +pattern BinOpApp x op y = OpVal op `App` x `App` y + +-- | Match a primop +pattern OpVal :: PrimOp -> Arg CoreBndr +pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where + OpVal op = Var (mkPrimOpId op) + + + +-- | Match a literal +pattern L :: Integer -> Arg CoreBndr +pattern L l <- Lit (isLitValue_maybe -> Just l) + +-- | Match an addition +pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :+: y <- BinOpApp x (isAddOp -> True) y + +-- | Match an addition with a literal (handle commutativity) +pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr +pattern l :++: x <- (isAdd -> Just (l,x)) + +isAdd :: CoreExpr -> Maybe (Integer,CoreExpr) +isAdd e = case e of + L l :+: x -> Just (l,x) + x :+: L l -> Just (l,x) + _ -> Nothing + +-- | Match a multiplication +pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :*: y <- BinOpApp x (isMulOp -> True) y + +-- | Match a multiplication with a literal (handle commutativity) +pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr +pattern l :**: x <- (isMul -> Just (l,x)) + +isMul :: CoreExpr -> Maybe (Integer,CoreExpr) +isMul e = case e of + L l :*: x -> Just (l,x) + x :*: L l -> Just (l,x) + _ -> Nothing + + +-- | Match a subtraction +pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :-: y <- BinOpApp x (isSubOp -> True) y + +isSubOp :: PrimOp -> Bool +isSubOp IntSubOp = True +isSubOp WordSubOp = True +isSubOp _ = False + +isAddOp :: PrimOp -> Bool +isAddOp IntAddOp = True +isAddOp WordAddOp = True +isAddOp _ = False + +isMulOp :: PrimOp -> Bool +isMulOp IntMulOp = True +isMulOp WordMulOp = True +isMulOp _ = False + +-- | Explicit "type-class"-like dictionary for numeric primops +-- +-- Depends on Platform because creating a literal value depends on Platform +data PrimOps = PrimOps + { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers + , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers + , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers + , mkL :: Integer -> CoreExpr -- ^ Create a literal value + } + +intPrimOps :: Platform -> PrimOps +intPrimOps platform = PrimOps + { add = \x y -> BinOpApp x IntAddOp y + , sub = \x y -> BinOpApp x IntSubOp y + , mul = \x y -> BinOpApp x IntMulOp y + , mkL = intResult' platform + } + +wordPrimOps :: Platform -> PrimOps +wordPrimOps platform = PrimOps + { add = \x y -> BinOpApp x WordAddOp y + , sub = \x y -> BinOpApp x WordSubOp y + , mul = \x y -> BinOpApp x WordMulOp y + , mkL = wordResult' platform + } + + +-------------------------------------------------------- +-- Constant folding through case-expressions +-- +-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Op.Simplify.Utils +-------------------------------------------------------- + +-- | Match the scrutinee of a case and potentially return a new scrutinee and a +-- function to apply to each literal alternative. +caseRules :: Platform + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> Maybe AltCon -- How to fix up the alt pattern + -- Nothing <=> Unreachable + -- See Note [Unreachable caseRules alternatives] + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder +-- e.g case e of b { +-- ...; +-- con bs -> rhs; +-- ... } +-- ==> +-- case e' of b' { +-- ...; +-- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; +-- ... } + +caseRules platform (App (App (Var f) v) (Lit l)) -- v `op` x# + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicRight op x + = Just (v, tx_lit_con platform adjust_lit + , \v -> (App (App (Var f) (Var v)) (Lit l))) + +caseRules platform (App (App (Var f) (Lit l)) v) -- x# `op` v + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicLeft x op + = Just (v, tx_lit_con platform adjust_lit + , \v -> (App (App (Var f) (Lit l)) (Var v))) + + +caseRules platform (App (Var f) v ) -- op v + | Just op <- isPrimOpId_maybe f + , Just adjust_lit <- adjustUnary op + = Just (v, tx_lit_con platform adjust_lit + , \v -> App (Var f) (Var v)) + +-- See Note [caseRules for tagToEnum] +caseRules platform (App (App (Var f) type_arg) v) + | Just TagToEnumOp <- isPrimOpId_maybe f + = Just (v, tx_con_tte platform + , \v -> (App (App (Var f) type_arg) (Var v))) + +-- See Note [caseRules for dataToTag] +caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x + | Just DataToTagOp <- isPrimOpId_maybe f + , Just (tc, _) <- tcSplitTyConApp_maybe ty + , isAlgTyCon tc + = Just (v, tx_con_dtt ty + , \v -> App (App (Var f) (Type ty)) (Var v)) + +caseRules _ _ = Nothing + + +tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon +tx_lit_con _ _ DEFAULT = Just DEFAULT +tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l) +tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) + -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the + -- literal alternatives remain in Word/Int target ranges + -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172). + +adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) +-- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x +adjustDyadicRight op lit + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> y+lit ) + IntSubOp -> Just (\y -> y+lit ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) + _ -> Nothing + +adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) +-- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x +adjustDyadicLeft lit op + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> lit-y ) + IntSubOp -> Just (\y -> lit-y ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) + _ -> Nothing + + +adjustUnary :: PrimOp -> Maybe (Integer -> Integer) +-- Given (op x) return a function 'f' s.t. f (op x) = x +adjustUnary op + = case op of + NotOp -> Just (\y -> complement y) + NotIOp -> Just (\y -> complement y) + IntNegOp -> Just (\y -> negate y ) + _ -> Nothing + +tx_con_tte :: Platform -> AltCon -> Maybe AltCon +tx_con_tte _ DEFAULT = Just DEFAULT +tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) +tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum] + = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc + +tx_con_dtt :: Type -> AltCon -> Maybe AltCon +tx_con_dtt _ DEFAULT = Just DEFAULT +tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) + | tag >= 0 + , tag < n_data_cons + = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) + | otherwise + = Nothing + where + tag = fromInteger i :: ConTagZ + tc = tyConAppTyCon ty + n_data_cons = tyConFamilySize tc + data_cons = tyConDataCons tc + +tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) + + +{- Note [caseRules for tagToEnum] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to transform + case tagToEnum x of + False -> e1 + True -> e2 +into + case x of + 0# -> e1 + 1# -> e2 + +This rule eliminates a lot of boilerplate. For + if (x>y) then e2 else e1 +we generate + case tagToEnum (x ># y) of + False -> e1 + True -> e2 +and it is nice to then get rid of the tagToEnum. + +Beware (#14768): avoid the temptation to map constructor 0 to +DEFAULT, in the hope of getting this + case (x ># y) of + DEFAULT -> e1 + 1# -> e2 +That fails utterly in the case of + data Colour = Red | Green | Blue + case tagToEnum x of + DEFAULT -> e1 + Red -> e2 + +We don't want to get this! + case x of + DEFAULT -> e1 + DEFAULT -> e2 + +Instead, we deal with turning one branch into DEFAULT in GHC.Core.Op.Simplify.Utils +(add_default in mkCase3). + +Note [caseRules for dataToTag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [dataToTag#] in primpops.txt.pp + +We want to transform + case dataToTag x of + DEFAULT -> e1 + 1# -> e2 +into + case x of + DEFAULT -> e1 + (:) _ _ -> e2 + +Note the need for some wildcard binders in +the 'cons' case. + +For the time, we only apply this transformation when the type of `x` is a type +headed by a normal tycon. In particular, we do not apply this in the case of a +data family tycon, since that would require carefully applying coercion(s) +between the data family and the data family instance's representation type, +which caseRules isn't currently engineered to handle (#14680). + +Note [Unreachable caseRules alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Take care if we see something like + case dataToTag x of + DEFAULT -> e1 + -1# -> e2 + 100 -> e3 +because there isn't a data constructor with tag -1 or 100. In this case the +out-of-range alternative is dead code -- we know the range of tags for x. + +Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating +an alternative that is unreachable. + +You may wonder how this can happen: check out #15436. +-} diff --git a/compiler/GHC/Core/Op/Monad.hs b/compiler/GHC/Core/Op/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Op/Monad.hs @@ -0,0 +1,828 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Op.Monad ( + -- * Configuration of the core-to-core passes + CoreToDo(..), runWhen, runMaybe, + SimplMode(..), + FloatOutSwitches(..), + pprPassDetails, + + -- * Plugins + CorePluginPass, bindsOnlyPass, + + -- * Counting + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..), + + -- * The monad + CoreM, runCoreM, + + -- ** Reading from the monad + getHscEnv, getRuleBase, getModule, + getDynFlags, getPackageFamInstEnv, + getVisibleOrphanMods, getUniqMask, + getPrintUnqualified, getSrcSpanM, + + -- ** Writing to the monad + addSimplCount, + + -- ** Lifting into the monad + liftIO, liftIOWithCount, + + -- ** Dealing with annotations + getAnnotations, getFirstAnnotations, + + -- ** Screen output + putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, + fatalErrorMsg, fatalErrorMsgS, + debugTraceMsg, debugTraceMsgS, + dumpIfSet_dyn + ) where + +import GhcPrelude hiding ( read ) + +import GHC.Core +import GHC.Driver.Types +import GHC.Types.Module +import GHC.Driver.Session +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Types.Annotations + +import IOEnv hiding ( liftIO, failM, failWithM ) +import qualified IOEnv ( liftIO ) +import GHC.Types.Var +import Outputable +import FastString +import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) +import GHC.Types.Unique.Supply +import MonadUtils +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import Data.Bifunctor ( bimap ) +import ErrUtils (dumpAction) +import Data.List (intersperse, groupBy, sortBy) +import Data.Ord +import Data.Dynamic +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import Data.Word +import Control.Monad +import Control.Applicative ( Alternative(..) ) +import Panic (throwGhcException, GhcException(..)) + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + Int -- Max iterations + SimplMode + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoDemand + | CoreDoCpr + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreOccurAnal + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _ _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr CoreDoDemand = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CorePrep = text "CorePrep" + ppr CoreOccurAnal = text "Occurrence analysis" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n + , ppr md ] +pprPassDetails _ = Outputable.empty + +data SimplMode -- See comments in GHC.Core.Op.Simplify.Monad + = SimplMode + { sm_names :: [String] -- Name(s) of the phase + , sm_phase :: CompilerPhase + , sm_dflags :: DynFlags -- Just for convenient non-monadic + -- access; we don't override these + , sm_rules :: Bool -- Whether RULES are enabled + , sm_inline :: Bool -- Whether inlining is enabled + , sm_case_case :: Bool -- Whether case-of-case is enabled + , sm_eta_expand :: Bool -- Whether eta-expansion is enabled + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p, sm_names = ss + , sm_rules = r, sm_inline = i + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (sLit "inline") <> comma + , pp_flag r (sLit "rules") <> comma + , pp_flag eta (sLit "eta-expand") <> comma + , pp_flag cc (sLit "case-of-case") ]) + where + pp_flag f s = ppUnless f (text "no") <+> ptext s + +data FloatOutSwitches = FloatOutSwitches { + floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if + -- doing so will abstract over n or fewer + -- value variables + -- Nothing <=> float all lambdas to top level, + -- regardless of how many free variables + -- Just 0 is the vanilla case: float a lambda + -- iff it has no free vars + + floatOutConstants :: Bool, -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + floatOutOverSatApps :: Bool, + -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in GHC.Core.Op.SetLevels + floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. + } +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw + = text "FOS" <+> (braces $ + sep $ punctuate comma $ + [ text "Lam =" <+> ppr (floatOutLambdas sw) + , text "Consts =" <+> ppr (floatOutConstants sw) + , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) + +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + +{- + +************************************************************************ +* * + Types for Plugins +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +{- +************************************************************************ +* * + Counting and logging +* * +************************************************************************ +-} + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: DynFlags -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dflags + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dopt Opt_D_dump_simpl_stats dflags + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick dflags tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount lhs rhs = + throwGhcException . PprProgramError "plusSimplCount" $ vcat + [ text "lhs" + , pprSimplCount lhs + , text "rhs" + , pprSimplCount rhs + ] + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +But alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void#->sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [[(Tick,Int)]] -- Each group shares a common tag + -- toList returns common tags adjacent + groups = groupBy same_tag (Map.toList counts) + same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 + +pprTickGroup :: [(Tick, Int)] -> SDoc +pprTickGroup group@((tick1,_):_) + = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortBy (flip (comparing snd)) group]) +pprTickGroup [] = panic "pprTickGroup" + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString LetFloatFromLet = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString SimplifierDone = "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ + +{- +************************************************************************ +* * + Monad and carried data structure definitions +* * +************************************************************************ +-} + +data CoreReader = CoreReader { + cr_hsc_env :: HscEnv, + cr_rule_base :: RuleBase, + cr_module :: Module, + cr_print_unqual :: PrintUnqualified, + cr_loc :: SrcSpan, -- Use this for log/error messages so they + -- are at least tagged with the right source file + cr_visible_orphan_mods :: !ModuleSet, + cr_uniq_mask :: !Char -- Mask for creating unique values +} + +-- Note: CoreWriter used to be defined with data, rather than newtype. If it +-- is defined that way again, the cw_simpl_count field, at least, must be +-- strict to avoid a space leak (#7702). +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +emptyWriter :: DynFlags -> CoreWriter +emptyWriter dflags = CoreWriter { + cw_simpl_count = zeroSimplCount dflags + } + +plusWriter :: CoreWriter -> CoreWriter -> CoreWriter +plusWriter w1 w2 = CoreWriter { + cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) + } + +type CoreIOEnv = IOEnv CoreReader + +-- | The monad used by Core-to-Core passes to register simplification statistics. +-- Also used to have common state (in the form of UniqueSupply) for generating Uniques. +newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } + deriving (Functor) + +instance Monad CoreM where + mx >>= f = CoreM $ do + (x, w1) <- unCoreM mx + (y, w2) <- unCoreM (f x) + let w = w1 `plusWriter` w2 + return $ seq w (y, w) + -- forcing w before building the tuple avoids a space leak + -- (#7702) + +instance Applicative CoreM where + pure x = CoreM $ nop x + (<*>) = ap + m *> k = m >>= \_ -> k + +instance Alternative CoreM where + empty = CoreM Control.Applicative.empty + m <|> n = CoreM (unCoreM m <|> unCoreM n) + +instance MonadPlus CoreM + +instance MonadUnique CoreM where + getUniqueSupplyM = do + mask <- read cr_uniq_mask + liftIO $! mkSplitUniqSupply mask + + getUniqueM = do + mask <- read cr_uniq_mask + liftIO $! uniqFromMask mask + +runCoreM :: HscEnv + -> RuleBase + -> Char -- ^ Mask + -> Module + -> ModuleSet + -> PrintUnqualified + -> SrcSpan + -> CoreM a + -> IO (a, SimplCount) +runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m + = liftM extract $ runIOEnv reader $ unCoreM m + where + reader = CoreReader { + cr_hsc_env = hsc_env, + cr_rule_base = rule_base, + cr_module = mod, + cr_visible_orphan_mods = orph_imps, + cr_print_unqual = print_unqual, + cr_loc = loc, + cr_uniq_mask = mask + } + + extract :: (a, CoreWriter) -> (a, SimplCount) + extract (value, writer) = (value, cw_simpl_count writer) + +{- +************************************************************************ +* * + Core combinators, not exported +* * +************************************************************************ +-} + +nop :: a -> CoreIOEnv (a, CoreWriter) +nop x = do + r <- getEnv + return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + +read :: (CoreReader -> a) -> CoreM a +read f = CoreM $ getEnv >>= (\r -> nop (f r)) + +write :: CoreWriter -> CoreM () +write w = CoreM $ return ((), w) + +-- \subsection{Lifting IO into the monad} + +-- | Lift an 'IOEnv' operation into 'CoreM' +liftIOEnv :: CoreIOEnv a -> CoreM a +liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) + +instance MonadIO CoreM where + liftIO = liftIOEnv . IOEnv.liftIO + +-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' +liftIOWithCount :: IO (SimplCount, a) -> CoreM a +liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) + +{- +************************************************************************ +* * + Reader, writer and state accessors +* * +************************************************************************ +-} + +getHscEnv :: CoreM HscEnv +getHscEnv = read cr_hsc_env + +getRuleBase :: CoreM RuleBase +getRuleBase = read cr_rule_base + +getVisibleOrphanMods :: CoreM ModuleSet +getVisibleOrphanMods = read cr_visible_orphan_mods + +getPrintUnqualified :: CoreM PrintUnqualified +getPrintUnqualified = read cr_print_unqual + +getSrcSpanM :: CoreM SrcSpan +getSrcSpanM = read cr_loc + +addSimplCount :: SimplCount -> CoreM () +addSimplCount count = write (CoreWriter { cw_simpl_count = count }) + +getUniqMask :: CoreM Char +getUniqMask = read cr_uniq_mask + +-- Convenience accessors for useful fields of HscEnv + +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv + +instance HasModule CoreM where + getModule = read cr_module + +getPackageFamInstEnv :: CoreM PackageFamInstEnv +getPackageFamInstEnv = do + hsc_env <- getHscEnv + eps <- liftIO $ hscEPS hsc_env + return $ eps_fam_inst_env eps + +{- +************************************************************************ +* * + Dealing with annotations +* * +************************************************************************ +-} + +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +-- +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. +-- +-- See Note [Annotations] +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) +getAnnotations deserialize guts = do + hsc_env <- getHscEnv + ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) + return (deserializeAnns deserialize ann_env) + +-- | Get at most one annotation of a given type per annotatable item. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) +getFirstAnnotations deserialize guts + = bimap mod name <$> getAnnotations deserialize guts + where + mod = mapModuleEnv head . filterModuleEnv (const $ not . null) + name = mapNameEnv head . filterNameEnv (not . null) + +{- +Note [Annotations] +~~~~~~~~~~~~~~~~~~ +A Core-to-Core pass that wants to make use of annotations calls +getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with +annotations of a specific type. This produces all annotations from interface +files read so far. However, annotations from interface files read during the +pass will not be visible until getAnnotations is called again. This is similar +to how rules work and probably isn't too bad. + +The current implementation could be optimised a bit: when looking up +annotations for a thing from the HomePackageTable, we could search directly in +the module where the thing is defined rather than building one UniqFM which +contains all annotations we know of. This would work because annotations can +only be given to things defined in the same module. However, since we would +only want to deserialise every annotation once, we would have to build a cache +for every module in the HTP. In the end, it's probably not worth it as long as +we aren't using annotations heavily. + +************************************************************************ +* * + Direct screen output +* * +************************************************************************ +-} + +msg :: Severity -> WarnReason -> SDoc -> CoreM () +msg sev reason doc + = do { dflags <- getDynFlags + ; loc <- getSrcSpanM + ; unqual <- getPrintUnqualified + ; let sty = case sev of + SevError -> err_sty + SevWarning -> err_sty + SevDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle dflags unqual + user_sty = mkUserStyle dflags unqual AllTheWay + dump_sty = mkDumpStyle dflags unqual + ; liftIO $ putLogMsg dflags reason sev loc sty doc } + +-- | Output a String message to the screen +putMsgS :: String -> CoreM () +putMsgS = putMsg . text + +-- | Output a message to the screen +putMsg :: SDoc -> CoreM () +putMsg = msg SevInfo NoReason + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsgS :: String -> CoreM () +errorMsgS = errorMsg . text + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsg :: SDoc -> CoreM () +errorMsg = msg SevError NoReason + +warnMsg :: WarnReason -> SDoc -> CoreM () +warnMsg = msg SevWarning + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsgS :: String -> CoreM () +fatalErrorMsgS = fatalErrorMsg . text + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsg :: SDoc -> CoreM () +fatalErrorMsg = msg SevFatal NoReason + +-- | Output a string debugging message at verbosity level of @-v@ or higher +debugTraceMsgS :: String -> CoreM () +debugTraceMsgS = debugTraceMsg . text + +-- | Outputs a debugging message at verbosity level of @-v@ or higher +debugTraceMsg :: SDoc -> CoreM () +debugTraceMsg = msg SevDump NoReason + +-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher +dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () +dumpIfSet_dyn flag str fmt doc + = do { dflags <- getDynFlags + ; unqual <- getPrintUnqualified + ; when (dopt flag dflags) $ liftIO $ do + let sty = mkDumpStyle dflags unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc } diff --git a/compiler/GHC/Core/Op/Monad.hs-boot b/compiler/GHC/Core/Op/Monad.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Op/Monad.hs-boot @@ -0,0 +1,30 @@ +-- Created this hs-boot file to remove circular dependencies from the use of +-- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core +-- transformations. +-- However GHC.Core.Op.Monad does much more than defining these, and because Plugins are +-- activated in various modules, the imports become circular. To solve this I +-- extracted CoreToDo and CoreM into this file. +-- I needed to write the whole definition of these types, otherwise it created +-- a data-newtype conflict. + +module GHC.Core.Op.Monad ( CoreToDo, CoreM ) where + +import GhcPrelude + +import IOEnv ( IOEnv ) + +type CoreIOEnv = IOEnv CoreReader + +data CoreReader + +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +data SimplCount + +newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } + +instance Monad CoreM + +data CoreToDo diff --git a/compiler/GHC/Core/Op/OccurAnal.hs b/compiler/GHC/Core/Op/OccurAnal.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Op/OccurAnal.hs @@ -0,0 +1,2898 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[OccurAnal]{Occurrence analysis pass} +* * +************************************************************************ + +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. +-} + +{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Op.OccurAnal ( + occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, + stripTicksTopE, mkTicks ) +import GHC.Core.Arity ( joinRhsArity ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name( localiseName ) +import GHC.Types.Basic +import GHC.Types.Module( Module ) +import GHC.Core.Coercion +import GHC.Core.Type + +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Demand ( argOneShots, argsOneShots ) +import Digraph ( SCC(..), Node(..) + , stronglyConnCompFromEdgedVerticesUniq + , stronglyConnCompFromEdgedVerticesUniqR ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import Util +import Outputable +import Data.List +import Control.Arrow ( second ) + +{- +************************************************************************ +* * + occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap +* * +************************************************************************ + +Here's the externally-callable interface: +-} + +occurAnalysePgm :: Module -- Used only in debug output + -> (Id -> Bool) -- Active unfoldings + -> (Activation -> Bool) -- Active rules + -> [CoreRule] + -> CoreProgram -> CoreProgram +occurAnalysePgm this_mod active_unf active_rule imp_rules binds + | isEmptyDetails final_usage + = occ_anald_binds + + | otherwise -- See Note [Glomming] + = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage ) ) + occ_anald_glommed_binds + where + init_env = initOccEnv { occ_rule_act = active_rule + , occ_unf_act = active_unf } + + (final_usage, occ_anald_binds) = go init_env binds + (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel + imp_rule_edges + (flattenBinds binds) + initial_uds + -- It's crucial to re-analyse the glommed-together bindings + -- so that we establish the right loop breakers. Otherwise + -- we can easily create an infinite loop (#9583 is an example) + -- + -- Also crucial to re-analyse the /original/ bindings + -- in case the first pass accidentally discarded as dead code + -- a binding that was actually needed (albeit before its + -- definition site). #17724 threw this up. + + initial_uds = addManyOccsSet emptyDetails + (rulesFreeVars imp_rules) + -- The RULES declarations keep things alive! + + -- Note [Preventing loops due to imported functions rules] + imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) $ + getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) + go _ [] + = (initial_uds, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + (bs_usage, binds') = go env binds + (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind + bs_usage + +occurAnalyseExpr :: CoreExpr -> CoreExpr + -- Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap + +occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr +occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap + +occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr +occurAnalyseExpr' enable_binder_swap expr + = snd (occAnal env expr) + where + env = initOccEnv { occ_binder_swap = enable_binder_swap } + +{- Note [Plugin rules] +~~~~~~~~~~~~~~~~~~~~~~ +Conal Elliott (#11651) built a GHC plugin that added some +BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to +do some domain-specific transformations that could not be expressed +with an ordinary pattern-matching CoreRule. But then we can't extract +the dependencies (in imp_rule_edges) from ru_rhs etc, because a +BuiltinRule doesn't have any of that stuff. + +So we simply assume that BuiltinRules have no dependencies, and filter +them out from the imp_rule_edges comprehension. +-} + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ + +Note [Recursive bindings: the grand plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across a binding group + Rec { x1 = r1; ...; xn = rn } +we treat it like this (occAnalRecBind): + +1. Occurrence-analyse each right hand side, and build a + "Details" for each binding to capture the results. + + Wrap the details in a Node (details, node-id, dep-node-ids), + where node-id is just the unique of the binder, and + dep-node-ids lists all binders on which this binding depends. + We'll call these the "scope edges". + See Note [Forming the Rec groups]. + + All this is done by makeNode. + +2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or + NonRec. The key property is that every free variable of a binding + is accounted for by the scope edges, so that when we are done + everything is still in scope. + +3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we + identify suitable loop-breakers to ensure that inlining terminates. + This is done by occAnalRec. + +4. To do so we form a new set of Nodes, with the same details, but + different edges, the "loop-breaker nodes". The loop-breaker nodes + have both more and fewer dependencies than the scope edges + (see Note [Choosing loop breakers]) + + More edges: if f calls g, and g has an active rule that mentions h + then we add an edge from f -> h + + Fewer edges: we only include dependencies on active rules, on rule + RHSs (not LHSs) and if there is an INLINE pragma only + on the stable unfolding (and vice versa). The scope + edges must be much more inclusive. + +5. The "weak fvs" of a node are, by definition: + the scope fvs - the loop-breaker fvs + See Note [Weak loop breakers], and the nd_weak field of Details + +6. Having formed the loop-breaker nodes + +Note [Dead code] +~~~~~~~~~~~~~~~~ +Dropping dead code for a cyclic Strongly Connected Component is done +in a very simple way: + + the entire SCC is dropped if none of its binders are mentioned + in the body; otherwise the whole thing is kept. + +The key observation is that dead code elimination happens after +dependency analysis: so 'occAnalBind' processes SCCs instead of the +original term's binding groups. + +Thus 'occAnalBind' does indeed drop 'f' in an example like + + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in +'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes +'AcyclicSCC f', where 'body_usage' won't contain 'f'. + +------------------------------------------------------------ +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" +and "g uses f", no matter how indirectly. We do a SCC analysis +with an edge f -> g if "f uses g". + +More precisely, "f uses g" iff g should be in scope wherever f is. +That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f (Note [Rules are extra RHSs]) + c) or the LHS or a rule for f (Note [Rule dependency info]) + +These conditions apply regardless of the activation of the RULE (eg it might be +inactive in this phase but become active later). Once a Rec is broken up +it can never be put back together, so we must be conservative. + +The principle is that, regardless of rule firings, every variable is +always in scope. + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + To that end, we build a Rec group for each cyclic strongly + connected component, + *treating f's rules as extra RHSs for 'f'*. + More concretely, the SCC analysis runs on a graph with an edge + from f -> g iff g is mentioned in + (a) f's rhs + (b) f's RULES + These are rec_edges. + + Under (b) we include variables free in *either* LHS *or* RHS of + the rule. The former might seems silly, but see Note [Rule + dependency info]. So in Example [eftInt], eftInt and eftIntFB + will be put in the same Rec, even though their 'main' RHSs are + both non-recursive. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a RuleInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Note [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + +------------------------------------------------------------ +Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. +We avoid infinite inlinings by choosing loop breakers, and +ensuring that a loop breaker cuts each loop. + +See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which +deals with a closely related source of infinite loops. + +Fundamentally, we do SCC analysis on a graph. For each recursive +group we choose a loop breaker, delete all edges to that node, +re-analyse the SCC, and iterate. + +But what is the graph? NOT the same graph as was used for Note +[Forming Rec groups]! In particular, a RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in GHC.Core.Op.Simplify + +Hence, if + f's RHS (or its INLINE template if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. + +In general, take the free variables of f's RHS, and augment it with +all the variables reachable by RULES from those starting points. That +is the whole reason for computing rule_fv_env in occAnalBind. (Of +course we only consider free vars that are also binders in this Rec +group.) See also Note [Finding rule RHS free vars] + +Note that when we compute this rule_fv_env, we only consider variables +free in the *RHS* of the rule, in contrast to the way we build the +Rec group in the first place (Note [Rule dependency info]) + +Note that if 'g' has RHS that mentions 'w', we should add w to +g's loop-breaker edges. More concretely there is an edge from f -> g +iff + (a) g is mentioned in f's RHS `xor` f's INLINE rhs + (see Note [Inline rules]) + (b) or h is mentioned in f's RHS, and + g appears in the RHS of an active RULE of h + or a transitive sequence of active rules starting with h + +Why "active rules"? See Note [Finding rule RHS free vars] + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note again that the edges of the graph we use for computing loop breakers +are not the same as the edges we use for computing the Rec blocks. +That's why we compute + +- rec_edges for the Rec block analysis +- loop_breaker_nodes for the loop breaker analysis + + * Note [Finding rule RHS free vars] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} + So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. + However, tagZero can only be inlined in phase 1 and later, while + the RULE is only active *before* phase 1. So there's no problem. + + To make this work, we look for the RHS free vars only for + *active* rules. That's the reason for the occ_rule_act field + of the OccEnv. + + * Note [Weak loop breakers] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... + } + + Remember that we simplify the RULES before any RHS (see Note + [Rules are visible in their own rec group] above). + + So we must *not* postInlineUnconditionally 'g', even though + its RHS turns out to be trivial. (I'm assuming that 'g' is + not chosen as a loop breaker.) Why not? Because then we + drop the binding for 'g', which leaves it out of scope in the + RULE! + + Here's a somewhat different example of the same thing + Rec { g = h + ; h = ...f... + ; f = f_rhs + RULE f [] = g } + Here the RULE is "below" g, but we *still* can't postInlineUnconditionally + g, because the RULE for f is active throughout. So the RHS of h + might rewrite to h = ...g... + So g must remain in scope in the output program! + + We "solve" this by: + + Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff g is a "missing free variable" of the Rec group + + A "missing free variable" x is one that is mentioned in an RHS or + INLINE or RULE of a binding in the Rec group, but where the + dependency on x may not show up in the loop_breaker_nodes (see + note [Choosing loop breakers} above). + + A normal "strong" loop breaker has IAmLoopBreaker False. So + + Inline postInlineUnconditionally + strong IAmLoopBreaker False no no + weak IAmLoopBreaker True yes no + other yes yes + + The **sole** reason for this kind of loop breaker is so that + postInlineUnconditionally does not fire. Ugh. (Typically it'll + inline via the usual callSiteInline stuff, so it'll be dead in the + next pass, so the main Ugh is the tiresome complication.) + +Note [Rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +Note that RULES for imported functions are important in practice; they +occur a lot in the libraries. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE RankNTypes #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add +dependency edges between the *local* FVS of the rule LHS and the +*local* FVS of the rule RHS. We don't do anything special for RULES on +local functions because the standard occurrence analysis stuff is +pretty good at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + +Note [Specialising imported functions] (referred to from Specialise) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT for *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [Rules for imported +functions]. In particular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might +not be as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to something at the bottom: + f = \x -> B.g (q x) + h = \y -> 3 + + RULE: B.g (q x) = h x + +Applying this rule makes f refer to h, although f doesn't appear to +depend on h. (And, as in Note [Rules for imported functions], the +dependency might be more indirect. For example, f might mention C.t +rather than B.g, where C.t eventually inlines to B.g.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.g in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +------------------------------------------------------------ +Note [Inline rules] +~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to Inline Rules, +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in GHC.Core.Op.Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. + +------------------------------------------------------------ +Note [Finding join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's the occurrence analyser's job to find bindings that we can turn into join +points, but it doesn't perform that transformation right away. Rather, it marks +the eligible bindings as part of their occurrence data, leaving it to the +simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. +The simplifier then eta-expands the RHS if needed and then updates the +occurrence sites. Dividing the work this way means that the occurrence analyser +still only takes one pass, yet one can always tell the difference between a +function call and a jump by looking at the occurrence (because the same pass +changes the 'IdDetails' and propagates the binders to their occurrence sites). + +To track potential join points, we use the 'occ_tail' field of OccInfo. A value +of `AlwaysTailCalled n` indicates that every occurrence of the variable is a +tail call with `n` arguments (counting both value and type arguments). Otherwise +'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the +rest of 'OccInfo' until it goes on the binder. + +Note [Rules and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Things get fiddly with rules. Suppose we have: + + let j :: Int -> Int + j y = 2 * y + k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 = j #-} + k x y = x + 2 * y + in ... + +Now suppose that both j and k appear only as saturated tail calls in the body. +Thus we would like to make them both join points. The rule complicates matters, +though, as its RHS has an unapplied occurrence of j. *However*, if we were to +eta-expand the rule, all would be well: + + {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} + +So conceivably we could notice that a potential join point would have an +"undersaturated" rule and account for it. This would mean we could make +something that's been specialised a join point, for instance. But local bindings +are rarely specialised, and being overly cautious about rules only +costs us anything when, for some `j`: + + * Before specialisation, `j` has non-tail calls, so it can't be a join point. + * During specialisation, `j` gets specialised and thus acquires rules. + * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), + and so now `j` *could* become a join point. + +This appears to be very rare in practice. TODO Perhaps we should gather +statistics to be sure. + +------------------------------------------------------------ +Note [Adjusting right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a dance we need to do after analysing a lambda expression or +a right-hand side. In particular, we need to + + a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot + lambda, or a non-recursive join point; and + b) call 'markAllNonTailCalled' *unless* the binding is for a join point. + +Some examples, with how the free occurrences in e (assumed not to be a value +lambda) get marked: + + inside lam non-tail-called + ------------------------------------------------------------ + let x = e No Yes + let f = \x -> e Yes Yes + let f = \x{OneShot} -> e No Yes + \x -> e Yes Yes + join j x = e No No + joinrec j x = e Yes No + +There are a few other caveats; most importantly, if we're marking a binding as +'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so +that the effect cascades properly. Consequently, at the time the RHS is +analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must +return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once +join-point-hood has been decided. + +Thus the overall sequence taking place in 'occAnalNonRecBind' and +'occAnalRecBind' is as follows: + + 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. + 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make + the binding a join point. + 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when + recursive.) + +(In the recursive case, this logic is spread between 'makeNode' and +'occAnalRec'.) +-} + +------------------------------------------------------------------ +-- occAnalBind +------------------------------------------------------------------ + +occAnalBind :: OccEnv -- The incoming OccEnv + -> TopLevelFlag + -> ImpRuleEdges + -> CoreBind + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [CoreBind]) + +occAnalBind env lvl top_env (NonRec binder rhs) body_usage + = occAnalNonRecBind env lvl top_env binder rhs body_usage +occAnalBind env lvl top_env (Rec pairs) body_usage + = occAnalRecBind env lvl top_env pairs body_usage + +----------------- +occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage + | isTyVar binder -- A type let; we don't gather usage info + = (body_usage, [NonRec binder rhs]) + + | not (binder `usedIn` body_usage) -- It's not mentioned + = (body_usage, []) + + | otherwise -- It's mentioned in the body + = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs']) + where + (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder + mb_join_arity = willBeJoinId_maybe tagged_binder + + (bndrs, body) = collectBinders rhs + + (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body + rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + + -- Unfoldings + -- See Note [Unfoldings and join points] + rhs_usage2 = case occAnalUnfolding env NonRecursive binder of + Just unf_usage -> rhs_usage1 `andUDs` unf_usage + Nothing -> rhs_usage1 + + -- Rules + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder + rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + rhs_usage3 = foldr andUDs rhs_usage2 rule_uds + rhs_usage4 = case lookupVarEnv imp_rule_edges binder of + Nothing -> rhs_usage3 + Just vs -> addManyOccsSet rhs_usage3 vs + -- See Note [Preventing loops due to imported functions rules] + + -- Final adjustment + rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 + +----------------- +occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalRecBind env lvl imp_rule_edges pairs body_usage + = foldr (occAnalRec env lvl) (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec + -- See Note [Recursive bindings: the grand plan] + where + sccs :: [SCC Details] + sccs = {-# SCC "occAnalBind.scc" #-} + stronglyConnCompFromEdgedVerticesUniq nodes + + nodes :: [LetrecNode] + nodes = {-# SCC "occAnalBind.assoc" #-} + map (makeNode env imp_rule_edges bndr_set) pairs + + bndr_set = mkVarSet (map fst pairs) + +{- +Note [Unfoldings and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We assume that anything in an unfolding occurs multiple times, since unfoldings +are often copied (that's the whole point!). But we still need to track tail +calls for the purpose of finding join points. +-} + +----------------------------- +occAnalRec :: OccEnv -> TopLevelFlag + -> SCC Details + -> (UsageDetails, [CoreBind]) + -> (UsageDetails, [CoreBind]) + + -- The NonRec case is just like a Let (NonRec ...) above +occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs + , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) + (body_uds, binds) + | not (bndr `usedIn` body_uds) + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- It's mentioned in the body + = (body_uds' `andUDs` rhs_uds', + NonRec tagged_bndr rhs : binds) + where + (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr + rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive + rhs_bndrs rhs_uds + + -- The Rec case is the interesting one + -- See Note [Recursive bindings: the grand plan] + -- See Note [Loop breaking] +occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) + | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- At this point we always build a single Rec + = -- pprTrace "occAnalRec" (vcat + -- [ text "weak_fvs" <+> ppr weak_fvs + -- , text "lb nodes" <+> ppr loop_breaker_nodes]) + (final_uds, Rec pairs : binds) + + where + bndrs = map nd_bndr details_s + bndr_set = mkVarSet bndrs + + ------------------------------ + -- See Note [Choosing loop breakers] for loop_breaker_nodes + final_uds :: UsageDetails + loop_breaker_nodes :: [LetrecNode] + (final_uds, loop_breaker_nodes) + = mkLoopBreakerNodes env lvl bndr_set body_uds details_s + + ------------------------------ + weak_fvs :: VarSet + weak_fvs = mapUnionVarSet nd_weak details_s + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] + | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] + -- If weak_fvs is empty, the loop_breaker_nodes will include + -- all the edges in the original scope edges [remember, + -- weak_fvs is the difference between scope edges and + -- lb-edges], so a fresh SCC computation would yield a + -- single CyclicSCC result; and reOrderNodes deals with + -- exactly that case + + +------------------------------------------------------------------ +-- Loop breaking +------------------------------------------------------------------ + +type Binding = (Id,CoreExpr) + +loopBreakNodes :: Int + -> VarSet -- All binders + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [LetrecNode] + -> [Binding] -- Append these to the end + -> [Binding] +{- +loopBreakNodes is applied to the list of nodes for a cyclic strongly +connected component (there's guaranteed to be a cycle). It returns +the same nodes, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma + +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. +-} + +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +loopBreakNodes depth bndr_set weak_fvs nodes binds + = -- pprTrace "loopBreakNodes" (ppr nodes) $ + go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds + where + go [] binds = binds + go (scc:sccs) binds = loop_break_scc scc (go sccs binds) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds + CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds + +---------------------------------- +reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- and call loopBreakNodes on the rest +reOrderNodes _ _ _ [] _ = panic "reOrderNodes" +reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds +reOrderNodes depth bndr_set weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen + -- , text "chosen" <+> ppr chosen_nodes ]) $ + loopBreakNodes new_depth bndr_set weak_fvs unchosen $ + (map mk_loop_breaker chosen_nodes ++ binds) + where + (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb + (nd_score (node_payload node)) + [node] [] nodes + + approximate_lb = depth >= 2 + new_depth | approximate_lb = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 + +mk_loop_breaker :: LetrecNode -> Binding +mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs}) + = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) + where + tail_info = tailCallInfo (idOccInfo bndr) + +mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding +-- See Note [Weak loop breakers] +mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr + , nd_rhs = rhs}) + | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) + | otherwise = (bndr, rhs) + where + occ' = weakLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +---------------------------------- +chooseLoopBreaker :: Bool -- True <=> Too many iterations, + -- so approximate + -> NodeScore -- Best score so far + -> [LetrecNode] -- Nodes with this score + -> [LetrecNode] -- Nodes with higher scores + -> [LetrecNode] -- Unprocessed nodes + -> ([LetrecNode], [LetrecNode]) + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in +chooseLoopBreaker _ _ loop_nodes acc [] + = (loop_nodes, acc) -- Done + + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] +chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) + | approx_lb + , rank sc == rank loop_sc + = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes + + | sc `betterLB` loop_sc -- Better score so pick this new one + = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes + + | otherwise -- Worse score so don't pick it + = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes + where + sc = nd_score (node_payload node) + +{- +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakders is +linear in the number of instance declarations. + +Note [Loop breakers and INLINE/INLINABLE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Avoid choosing a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +It's vital to distinguish between INLINE and INLINABLE (the +Bool returned by hasStableCoreUnfolding_maybe). If we start with + Rec { {-# INLINABLE f #-} + f x = ...f... } +and then worker/wrapper it through strictness analysis, we'll get + Rec { {-# INLINABLE $wf #-} + $wf p q = let x = (p,q) in ...f... + + {-# INLINE f #-} + f x = case x of (p,q) -> $wf p q } + +Now it is vital that we choose $wf as the loop breaker, so we can +inline 'f' in '$wf'. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in TcInstDcls + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-loop breaker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. + +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. + + +@occAnalUnfolding@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that this +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. + + +************************************************************************ +* * + Making nodes +* * +************************************************************************ +-} + +type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs + +noImpRuleEdges :: ImpRuleEdges +noImpRuleEdges = emptyVarEnv + +type LetrecNode = Node Unique Details -- Node comes from Digraph + -- The Unique key is gotten from the Id +data Details + = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS, already occ-analysed + , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS + -- INVARIANT: (nd_rhs_bndrs nd, _) == + -- collectBinders (nd_rhs nd) + + , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings + -- ignoring phase (ie assuming all are active) + -- See Note [Forming Rec groups] + + , nd_inl :: IdSet -- Free variables of + -- the stable unfolding (if present and active) + -- or the RHS (if not) + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds + -- but are *not* in nd_inl. These are the ones whose + -- dependencies might not be respected by loop_breaker_nodes + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES + + , nd_score :: NodeScore + } + +instance Outputable Details where + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr (nd_uds nd) + , text "inl =" <+> ppr (nd_inl nd) + , text "weak =" <+> ppr (nd_weak nd) + , text "rule =" <+> ppr (nd_active_rule_fvs nd) + , text "score =" <+> ppr (nd_score nd) + ]) + +-- The NodeScore is compared lexicographically; +-- e.g. lower rank wins regardless of size +type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker + , Int -- Size of rhs: higher => more likely to be picked as LB + -- Maxes out at maxExprSize; we just use it to prioritise + -- small functions + , Bool ) -- Was it a loop breaker before? + -- True => more likely to be picked + -- Note [Loop breakers, node scoring, and stability] + +rank :: NodeScore -> Int +rank (r, _, _) = r + +makeNode :: OccEnv -> ImpRuleEdges -> VarSet + -> (Var, CoreExpr) -> LetrecNode +-- See Note [Recursive bindings: the grand plan] +makeNode env imp_rule_edges bndr_set (bndr, rhs) + = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) + -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR + -- is still deterministic with edges in nondeterministic order as + -- explained in Note [Deterministic SCC] in Digraph. + where + details = ND { nd_bndr = bndr + , nd_rhs = rhs' + , nd_rhs_bndrs = bndrs' + , nd_uds = rhs_usage3 + , nd_inl = inl_fvs + , nd_weak = node_fvs `minusVarSet` inl_fvs + , nd_active_rule_fvs = active_rule_fvs + , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } + + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + (bndrs, body) = collectBinders rhs + (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body + rhs' = mkLams bndrs' body' + rhs_usage2 = foldr andUDs rhs_usage1 rule_uds + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_usage3 = case mb_unf_uds of + Just unf_uds -> rhs_usage2 `andUDs` unf_uds + Nothing -> rhs_usage2 + node_fvs = udFreeVars bndr_set rhs_usage3 + + -- Finding the free variables of the rules + is_active = occ_rule_act env :: Activation -> Bool + + rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] + rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr + + rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs + rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) + (lookupVarEnv imp_rule_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, udFreeVars bndr_set rhs_uds) + | (rule, _, rhs_uds) <- rules_w_uds ] + rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs + , is_active a] + + -- Finding the usage details of the INLINE pragma (if any) + mb_unf_uds = occAnalUnfolding env Recursive bndr + + -- Find the "nd_inl" free vars; for the loop-breaker phase + inl_fvs = case mb_unf_uds of + Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS + Just unf_uds -> udFreeVars bndr_set unf_uds + -- We could check for an *active* INLINE (returning + -- emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about + -- RULE activation), so we'd need more plumbing + +mkLoopBreakerNodes :: OccEnv -> TopLevelFlag + -> VarSet + -> UsageDetails -- for BODY of let + -> [Details] + -> (UsageDetails, -- adjusted + [LetrecNode]) +-- Does four things +-- a) tag each binder with its occurrence info +-- b) add a NodeScore to each node +-- c) make a Node with the right dependency edges for +-- the loop-breaker SCC analysis +-- d) adjust each RHS's usage details according to +-- the binder's (new) shotness and join-point-hood +mkLoopBreakerNodes env lvl bndr_set body_uds details_s + = (final_uds, zipWith mk_lb_node details_s bndrs') + where + (final_uds, bndrs') = tagRecBinders lvl body_uds + [ ((nd_bndr nd) + ,(nd_uds nd) + ,(nd_rhs_bndrs nd)) + | nd <- details_s ] + mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' + = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps) + -- It's OK to use nonDetKeysUniqSet here as + -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges + -- in nondeterministic order as explained in + -- Note [Deterministic SCC] in Digraph. + where + nd' = nd { nd_bndr = bndr', nd_score = score } + score = nodeScore env bndr bndr' rhs lb_deps + lb_deps = extendFvs_ rule_fv_env inl_fvs + + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- mentioned in RHS of active rules for f + -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) + init_rule_fvs -- See Note [Finding rule RHS free vars] + = [ (b, trimmed_rule_fvs) + | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s + , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set + , not (isEmptyVarSet trimmed_rule_fvs) ] + + +------------------------------------------ +nodeScore :: OccEnv + -> Id -- Binder has old occ-info (just for loop-breaker-ness) + -> Id -- Binder with new occ-info + -> CoreExpr -- RHS + -> VarSet -- Loop-breaker dependencies + -> NodeScore +nodeScore env old_bndr new_bndr bind_rhs lb_deps + | not (isId old_bndr) -- A type or coercion variable is never a loop breaker + = (100, 0, False) + + | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers + = (0, 0, True) -- See Note [Self-recursion and loop breakers] + + | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + + | exprIsTrivial rhs + = mk_score 10 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + | DFunUnfolding { df_args = args } <- id_unfolding + -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] + = (9, length args, is_lb) + + -- Data structures are more important than INLINE pragmas + -- so that dictionary/method recursion unravels + + | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding + = mk_score 6 + + | is_con_app rhs -- Data types help with cases: + = mk_score 5 -- Note [Constructor applications] + + | isStableUnfolding id_unfolding + , can_unfold + = mk_score 3 + + | isOneOcc (idOccInfo new_bndr) + = mk_score 2 -- Likely to be inlined + + | can_unfold -- The Id has some kind of unfolding + = mk_score 1 + + | otherwise + = (0, 0, is_lb) + + where + mk_score :: Int -> NodeScore + mk_score rank = (rank, rhs_size, is_lb) + + is_lb = isStrongLoopBreaker (idOccInfo old_bndr) + rhs = case id_unfolding of + CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } + | isStableSource src + -> unf_rhs + _ -> bind_rhs + -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding + rhs_size = case id_unfolding of + CoreUnfolding { uf_guidance = guidance } + | UnfIfGoodArgs { ug_size = size } <- guidance + -> size + _ -> cheapExprSize rhs + + can_unfold = canUnfold id_unfolding + id_unfolding = realIdUnfolding old_bndr + -- realIdUnfolding: Ignore loop-breaker-ness here because + -- that is what we are setting! + + -- Checking for a constructor application + -- Cheap and cheerful; the simplifier moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isConLikeId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Tick _ e) = is_con_app e + is_con_app _ = False + +maxExprSize :: Int +maxExprSize = 20 -- Rather arbitrary + +cheapExprSize :: CoreExpr -> Int +-- Maxes out at maxExprSize +cheapExprSize e + = go 0 e + where + go n e | n >= maxExprSize = n + | otherwise = go1 n e + + go1 n (Var {}) = n+1 + go1 n (Lit {}) = n+1 + go1 n (Type {}) = n + go1 n (Coercion {}) = n + go1 n (Tick _ e) = go1 n e + go1 n (Cast e _) = go1 n e + go1 n (App f a) = go (go1 n f) a + go1 n (Lam b e) + | isTyVar b = go1 n e + | otherwise = go (n+1) e + go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) + go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) + + gos n [] = n + gos n (e:es) | n >= maxExprSize = n + | otherwise = gos (go1 n e) es + +betterLB :: NodeScore -> NodeScore -> Bool +-- If n1 `betterLB` n2 then choose n1 as the loop breaker +betterLB (rank1, size1, lb1) (rank2, size2, _) + | rank1 < rank2 = True + | rank1 > rank2 = False + | size1 < size2 = False -- Make the bigger n2 into the loop breaker + | size1 > size2 = True + | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it + | otherwise = False -- See Note [Loop breakers, node scoring, and stability] + +{- Note [Self-recursion and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + rec { f = ...f...g... + ; g = .....f... } +then 'f' has to be a loop breaker anyway, so we may as well choose it +right away, so that g can inline freely. + +This is really just a cheap hack. Consider + rec { f = ...g... + ; g = ..f..h... + ; h = ...f....} +Here f or g are better loop breakers than h; but we might accidentally +choose h. Finding the minimal set of loop breakers is hard. + +Note [Loop breakers, node scoring, and stability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To choose a loop breaker, we give a NodeScore to each node in the SCC, +and pick the one with the best score (according to 'betterLB'). + +We need to be jolly careful (#12425, #12234) about the stability +of this choice. Suppose we have + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...f.. + False -> ..f... + +In each iteration of the simplifier the occurrence analyser OccAnal +chooses a loop breaker. Suppose in iteration 1 it choose g as the loop +breaker. That means it is free to inline f. + +Suppose that GHC decides to inline f in the branches of the case, but +(for some reason; eg it is not saturated) in the rhs of g. So we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...g...g..... + False -> ..g..g.... + +Now suppose that, for some reason, in the next iteration the occurrence +analyser chooses f as the loop breaker, so it can freely inline g. And +again for some reason the simplifier inlines g at its calls in the case +branches, but not in the RHS of f. Then we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...(...f...f...)...(...f..f..)..... + False -> ..(...f...f...)...(..f..f...).... + +You can see where this is going! Each iteration of the simplifier +doubles the number of calls to f or g. No wonder GHC is slow! + +(In the particular example in comment:3 of #12425, f and g are the two +mutually recursive fmap instances for CondT and Result. They are both +marked INLINE which, oddly, is why they don't inline in each other's +RHS, because the call there is not saturated.) + +The root cause is that we flip-flop on our choice of loop breaker. I +always thought it didn't matter, and indeed for any single iteration +to terminate, it doesn't matter. But when we iterate, it matters a +lot!! + +So The Plan is this: + If there is a tie, choose the node that + was a loop breaker last time round + +Hence the is_lb field of NodeScore + +************************************************************************ +* * + Right hand sides +* * +************************************************************************ +-} + +occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr + -> (UsageDetails, [CoreBndr], CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalRhs env Recursive _ bndrs body + = occAnalRecRhs env bndrs body +occAnalRhs env NonRecursive id bndrs body + = occAnalNonRecRhs env id bndrs body + +occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body + -> (UsageDetails, [CoreBndr], CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body + +occAnalNonRecRhs :: OccEnv + -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body + -- Binder is already tagged with occurrence info + -> (UsageDetails, [CoreBndr], CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalNonRecRhs env bndr bndrs body + = occAnalLamOrRhs rhs_env bndrs body + where + env1 | is_join_point = env -- See Note [Join point RHSs] + | certainly_inline = env -- See Note [Cascading inlines] + | otherwise = rhsCtxt env + + -- See Note [Sources of one-shot information] + rhs_env = env1 { occ_one_shots = argOneShots dmd } + + certainly_inline -- See Note [Cascading inlines] + = case occ of + OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch } + -> active && not_stable + _ -> False + + is_join_point = isAlwaysTailCalled occ + -- Like (isJoinId bndr) but happens one step earlier + -- c.f. willBeJoinId_maybe + + occ = idOccInfo bndr + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) + +occAnalUnfolding :: OccEnv + -> RecFlag + -> Id + -> Maybe UsageDetails + -- Just the analysis, not a new unfolding. The unfolding + -- got analysed when it was created and we don't need to + -- update it. +occAnalUnfolding env rec_flag id + = case realIdUnfolding id of -- ignore previous loop-breaker flag + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | not (isStableSource src) + -> Nothing + | otherwise + -> Just $ markAllMany usage + where + (bndrs, body) = collectBinders rhs + (usage, _, _) = occAnalRhs env rec_flag id bndrs body + + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just $ zapDetails (delDetailsList usage bndrs) + where + usage = andUDsList (map (fst . occAnal env) args) + + _ -> Nothing + +occAnalRules :: OccEnv + -> Maybe JoinArity -- If the binder is (or MAY become) a join + -- point, what its join arity is (or WOULD + -- become). See Note [Rules and join points]. + -> RecFlag + -> Id + -> [(CoreRule, -- Each (non-built-in) rule + UsageDetails, -- Usage details for LHS + UsageDetails)] -- Usage details for RHS +occAnalRules env mb_expected_join_arity rec_flag id + = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id + , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] + where + occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = (lhs_uds, final_rhs_uds) + where + lhs_uds = addManyOccsSet emptyDetails $ + (exprsFreeVars args `delVarSetList` bndrs) + (rhs_bndrs, rhs_body) = collectBinders rhs + (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + final_rhs_uds = adjust_tail_info args $ markAllMany $ + (rhs_uds `delDetailsList` bndrs) + occ_anal_rule _ + = (emptyDetails, emptyDetails) + + adjust_tail_info args uds -- see Note [Rules and join points] + = case mb_expected_join_arity of + Just ar | args `lengthIs` ar -> uds + _ -> markAllNonTailCalled uds +{- Note [Join point RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = e + join j = Just x + +We want to inline x into j right away, so we don't want to give +the join point a RhsCtxt (#14137). It's not a huge deal, because +the FloatIn pass knows to float into join point RHSs; and the simplifier +does not float things out of join point RHSs. But it's a simple, cheap +thing to do. See #14137. + +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an rhsCtxt for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximate GHC.Core.Op.Simplify.Utils.preInlineUnconditionally. +If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and + (b) certainly_inline says "yes" when preInlineUnconditionally says "no" +then the simplifier iterates indefinitely: + x = f y + k = Just x -- We decide that k is 'certainly_inline' + v = ...k... -- but preInlineUnconditionally doesn't inline it +inline ==> + k = Just (f y) + v = ...k... +float ==> + x1 = f y + k = Just x1 + v = ...k... + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. + + +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +occAnal :: OccEnv + -> CoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + CoreExpr) + +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var _) = occAnalApp env (expr, [], []) + -- At one stage, I gathered the idRuleVars for the variable here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + +occAnal _ (Coercion co) + = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion variables] + +{- +Note [Gather occurrences of coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. +-} + +occAnal env (Tick tickish body) + | SourceNote{} <- tickish + = (usage, Tick tickish body') + -- SourceNotes are best-effort; so we just proceed as usual. + -- If we drop a tick due to the issues described below it's + -- not the end of the world. + + | tickish `tickishScopesLike` SoftScope + = (markAllNonTailCalled usage, Tick tickish body') + + | Breakpoint _ ids <- tickish + = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') + -- never substitute for any of the Ids in a Breakpoint + + | otherwise + = (usage_lam, Tick tickish body') + where + !(usage,body') = occAnal env body + -- for a non-soft tick scope, we can inline lambdas only + usage_lam = markAllNonTailCalled (markAllInsideLam usage) + -- TODO There may be ways to make ticks and join points play + -- nicer together, but right now there are problems: + -- let j x = ... in tick (j 1) + -- Making j a join point may cause the simplifier to drop t + -- (if the tick is put into the continuation). So we don't + -- count j 1 as a tail call. + -- See #14242. + +occAnal env (Cast expr co) + = case occAnal env expr of { (usage, expr') -> + let usage1 = zapDetailsIf (isRhsEnv env) usage + -- usage1: if we see let x = y `cast` co + -- then mark y as 'Many' so that we don't + -- immediately inline y again. + usage2 = addManyOccsSet usage1 (coVarsOfCo co) + -- usage2: see Note [Gather occurrences of coercion variables] + in (markAllNonTailCalled usage2, Cast expr' co) + } + +occAnal env app@(App _ _) + = occAnalApp env (collectArgsTicks tickishFloatable app) + +-- Ignore type variables altogether +-- (a) occurrences inside type lambdas only not marked as InsideLam +-- (b) type variables not in environment + +occAnal env (Lam x body) + | isTyVar x + = case occAnal env body of { (body_usage, body') -> + (markAllNonTailCalled body_usage, Lam x body') + } + +-- For value lambdas we do a special hack. Consider +-- (\x. \y. ...x...) +-- If we did nothing, x is used inside the \y, so would be marked +-- as dangerous to dup. But in the common case where the abstraction +-- is applied to two arguments this is over-pessimistic. +-- So instead, we just mark each binder with its occurrence +-- info in the *body* of the multiple lambda. +-- Then, the simplifier is careful when partially applying lambdas. + +occAnal env expr@(Lam _ _) + = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> + let + expr' = mkLams tagged_binders body' + usage1 = markAllNonTailCalled usage + one_shot_gp = all isOneShotBndr tagged_binders + final_usage | one_shot_gp = usage1 + | otherwise = markAllInsideLam usage1 + in + (final_usage, expr') } + where + (binders, body) = collectBinders expr + +occAnal env (Case scrut bndr ty alts) + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> + let + alts_usage = foldr orUDs emptyDetails alts_usage_s + (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr + total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1 + -- Alts can have tail calls, but the scrutinee can't + in + total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} + where + alt_env = mkAltEnv env scrut bndr + occ_anal_alt = occAnalAlt alt_env + + occ_anal_scrut (Var v) (alt1 : other_alts) + | not (null other_alts) || not (isDefaultAlt alt1) + = (mkOneOcc env v IsInteresting 0, Var v) + -- The 'True' says that the variable occurs in an interesting + -- context; the case has at least one non-default alternative + occ_anal_scrut (Tick t e) alts + | t `tickishScopesLike` SoftScope + -- No reason to not look through all ticks here, but only + -- for soft-scoped ticks we can do so without having to + -- update returned occurrence info (see occAnal) + = second (Tick t) $ occ_anal_scrut e alts + + occ_anal_scrut scrut _alts + = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt + +occAnal env (Let bind body) + = case occAnal env body of { (body_usage, body') -> + case occAnalBind env NotTopLevel + noImpRuleEdges bind + body_usage of { (final_usage, new_binds) -> + (final_usage, mkLets new_binds body') }} + +occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) +occAnalArgs _ [] _ + = (emptyDetails, []) + +occAnalArgs env (arg:args) one_shots + | isTypeArg arg + = case occAnalArgs env args one_shots of { (uds, args') -> + (uds, arg:args') } + + | otherwise + = case argCtxt env one_shots of { (arg_env, one_shots') -> + case occAnal arg_env arg of { (uds1, arg') -> + case occAnalArgs env args one_shots' of { (uds2, args') -> + (uds1 `andUDs` uds2, arg':args') }}} + +{- +Applications are dealt with specially because we want +the "build hack" to work. + +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. +-} + +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) + -> (UsageDetails, Expr CoreBndr) +occAnalApp env (Var fun, args, ticks) + | null ticks = (uds, mkApps (Var fun) args') + | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') + where + uds = fun_uds `andUDs` final_args_uds + + !(args_uds, args') = occAnalArgs env args one_shots + !final_args_uds + | isRhsEnv env && is_exp = markAllNonTailCalled $ + markAllInsideLam args_uds + | otherwise = markAllNonTailCalled args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "inside-lambda", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor or PAP + -- argument position, which is what we want. Typically those + -- constructor arguments are just variables, or trivial expressions. + -- We use inside-lam because it's like eta-expanding the PAP. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] + + n_val_args = valArgCount args + n_args = length args + fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args + is_exp = isExpandableApp fun n_val_args + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in GHC.Core.Op.Simplify.prepareRhs + + one_shots = argsOneShots (idStrictness fun) guaranteed_val_args + guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo + (occ_one_shots env)) + -- See Note [Sources of one-shot information], bullet point A'] + +occAnalApp env (fun, args, ticks) + = (markAllNonTailCalled (fun_uds `andUDs` args_uds), + mkTicks ticks $ mkApps fun' args') + where + !(fun_uds, fun') = occAnal (addAppCtxt env args) fun + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexs like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some True items + -- onto the context stack. + !(args_uds, args') = occAnalArgs env args [] + +zapDetailsIf :: Bool -- If this is true + -> UsageDetails -- Then do zapDetails on this + -> UsageDetails +zapDetailsIf True uds = zapDetails uds +zapDetailsIf False uds = uds + +{- +Note [Sources of one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrence analyser obtains one-shot-lambda information from two sources: + +A: Saturated applications: eg f e1 .. en + + In general, given a call (f e1 .. en) we can propagate one-shot info from + f's strictness signature into e1 .. en, but /only/ if n is enough to + saturate the strictness signature. A strictness signature like + + f :: C1(C1(L))LS + + means that *if f is applied to three arguments* then it will guarantee to + call its first argument at most once, and to call the result of that at + most once. But if f has fewer than three arguments, all bets are off; e.g. + + map (f (\x y. expensive) e2) xs + + Here the \x y abstraction may be called many times (once for each element of + xs) so we should not mark x and y as one-shot. But if it was + + map (f (\x y. expensive) 3 2) xs + + then the first argument of f will be called at most once. + + The one-shot info, derived from f's strictness signature, is + computed by 'argsOneShots', called in occAnalApp. + +A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) + where f is as above. + + In this case, f is only manifestly applied to one argument, so it does not + look saturated. So by the previous point, we should not use its strictness + signature to learn about the one-shotness of \x y. But in this case we can: + build is fully applied, so we may use its strictness signature; and from + that we learn that build calls its argument with two arguments *at most once*. + + So there is really only one call to f, and it will have three arguments. In + that sense, f is saturated, and we may proceed as described above. + + Hence the computation of 'guaranteed_val_args' in occAnalApp, using + '(occ_one_shots env)'. See also #13227, comment:9 + +B: Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + + Propagate one-shot info from the demanand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) + + This information must have come from a previous run of the demanand + analyser. + +Previously, the demand analyser would *also* set the one-shot information, but +that code was buggy (see #11770), so doing it only in on place, namely here, is +saner. + +Note [OneShots] +~~~~~~~~~~~~~~~ +When analysing an expression, the occ_one_shots argument contains information +about how the function is being used. The length of the list indicates +how many arguments will eventually be passed to the analysed expression, +and the OneShotInfo indicates whether this application is once or multiple times. + +Example: + + Context of f occ_one_shots when analysing f + + f 1 2 [OneShot, OneShot] + map (f 1) [OneShot, NoOneShotInfo] + build f [OneShot, OneShot] + f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, because it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). +-} + +occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr + -> (UsageDetails, [CoreBndr], CoreExpr) +occAnalLamOrRhs env [] body + = case occAnal env body of (body_usage, body') -> (body_usage, [], body') + -- RHS of thunk or nullary join point +occAnalLamOrRhs env (bndr:bndrs) body + | isTyVar bndr + = -- Important: Keep the environment so that we don't inline into an RHS like + -- \(@ x) -> C @x (f @x) + -- (see the beginning of Note [Cascading inlines]). + case occAnalLamOrRhs env bndrs body of + (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') +occAnalLamOrRhs env binders body + = case occAnal env_body body of { (body_usage, body') -> + let + (final_usage, tagged_binders) = tagLamBinders body_usage binders' + -- Use binders' to put one-shot info on the lambdas + in + (final_usage, tagged_binders, body') } + where + (env_body, binders') = oneShotGroup env binders + +occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) + -> CoreAlt + -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt (env, scrut_bind) (con, bndrs, rhs) + = case occAnal env rhs of { (rhs_usage1, rhs1) -> + let + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs + -- See Note [Binders in case alternatives] + (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 + in + (alt_usg', (con, tagged_bndrs, rhs2)) } + +wrapAltRHS :: OccEnv + -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv + -> UsageDetails -- usage for entire alt (p -> rhs) + -> [Var] -- alt binders + -> CoreExpr -- alt RHS + -> (UsageDetails, CoreExpr) +wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs + | occ_binder_swap env + , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this + -- handles condition (a) in Note [Binder swap] + , not captured -- See condition (b) in Note [Binder swap] + = ( alt_usg' `andUDs` let_rhs_usg + , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) + where + captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) + + -- The rhs of the let may include coercion variables + -- if the scrutinee was a cast, so we must gather their + -- usage. See Note [Gather occurrences of coercion variables] + -- Moreover, the rhs of the let may mention the case-binder, and + -- we want to gather its occ-info as well + (let_rhs_usg, let_rhs') = occAnal env let_rhs + + (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var + +wrapAltRHS _ _ alt_usg _ alt_rhs + = (alt_usg, alt_rhs) + +{- +************************************************************************ +* * + OccEnv +* * +************************************************************************ +-} + +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- See Note [OneShots] + , occ_gbl_scrut :: GlobalScruts + + , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active + + , occ_rule_act :: Activation -> Bool -- Which rules are active + -- See Note [Finding rule RHS free vars] + + , occ_binder_swap :: !Bool -- enable the binder_swap + -- See CorePrep Note [Dead code in CorePrep] + } + +type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] + +----------------------------- +-- OccEncl is used to control whether to inline into constructor arguments +-- For example: +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- So OccEncl tells enough about the context to know what to do when +-- we encounter a constructor application or PAP. + +data OccEncl + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. + -- Do inline into constructor args here + +instance Outputable OccEncl where + ppr OccRhs = text "occRhs" + ppr OccVanilla = text "occVanilla" + +-- See note [OneShots] +type OneShots = [OneShotInfo] + +initOccEnv :: OccEnv +initOccEnv + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] + , occ_gbl_scrut = emptyVarSet + -- To be conservative, we say that all + -- inlines and rules are active + , occ_unf_act = \_ -> True + , occ_rule_act = \_ -> True + , occ_binder_swap = True } + +vanillaCtxt :: OccEnv -> OccEnv +vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } + +rhsCtxt :: OccEnv -> OccEnv +rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } + +argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) +argCtxt env [] + = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) +argCtxt env (one_shots:one_shots_s) + = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = OccRhs }) = True +isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False + +oneShotGroup :: OccEnv -> [CoreBndr] + -> ( OccEnv + , [CoreBndr] ) + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\c n -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out transformations + +oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs + = go ctxt bndrs [] + where + go ctxt [] rev_bndrs + = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } + , reverse rev_bndrs ) + + go [] bndrs rev_bndrs + = ( env { occ_one_shots = [], occ_encl = OccVanilla } + , reverse rev_bndrs ++ bndrs ) + + go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs + | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) + | otherwise = go ctxt bndrs (bndr : rev_bndrs) + where + bndr' = updOneShotInfo bndr one_shot + -- Use updOneShotInfo, not setOneShotInfo, as pre-existing + -- one-shot info might be better than what we can infer, e.g. + -- due to explicit use of the magic 'oneShot' function. + -- See Note [The oneShot function] + + +markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] +-- Mark the lambdas of a non-recursive join point as one-shot. +-- This is good to prevent gratuitous float-out etc +markJoinOneShots mb_join_arity bndrs + = case mb_join_arity of + Nothing -> bndrs + Just n -> go n bndrs + where + go 0 bndrs = bndrs + go _ [] = [] -- This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + go n (b:bs) = b' : go (n-1) bs + where + b' | isId b = setOneShotLambda b + | otherwise = b + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } + +transClosureFV :: UniqFM VarSet -> UniqFM VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +-- as well as (f,g), (g,h) +transClosureFV env + | no_change = env + | otherwise = transClosureFV (listToUFM new_fv_list) + where + (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) + -- It's OK to use nonDetUFMToList here because we'll forget the + -- ordering by creating a new set with listToUFM + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + +extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) + where + extras :: VarSet -- env(s) + extras = nonDetFoldUFM unionVarSet emptyVarSet $ + -- It's OK to use nonDetFoldUFM here because unionVarSet commutes + intersectUFM_C (\x _ -> x) env (getUniqSet s) + +{- +************************************************************************ +* * + Binder swap +* * +************************************************************************ + +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +The "binder swap" transformation swaps occurrence of the +scrutinee of a case for occurrences of the case-binder: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> let x=b in ri } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> let x = b |> sym co in ri } + +In both cases, the trivial 'let' can be eliminated by the +immediately following simplifier pass. + +There are two reasons for making this swap: + +(A) It reduces the number of occurrences of the scrutinee, x. + That in turn might reduce its occurrences to one, so we + can inline it and save an allocation. E.g. + let x = factorial y in case x of b { I# v -> ...x... } + If we replace 'x' by 'b' in the alternative we get + let x = factorial y in case x of b { I# v -> ...b... } + and now we can inline 'x', thus + case (factorial y) of b { I# v -> ...b... } + +(B) The case-binder b has unfolding information; in the + example above we know that b = I# v. That in turn allows + nested cases to simplify. Consider + case x of b { I# v -> + ...(case x of b2 { I# v2 -> rhs })... + If we replace 'x' by 'b' in the alternative we get + case x of b { I# v -> + ...(case b of b2 { I# v2 -> rhs })... + and now it is trivial to simplify the inner case: + case x of b { I# v -> + ...(let b2 = b in rhs)... + + The same can happen even if the scrutinee is a variable + with a cast: see Note [Case of cast] + +In both cases, in a particular alternative (pi -> ri), we only +add the binding if + (a) x occurs free in (pi -> ri) + (ie it occurs in ri, but is not bound in pi) + (b) the pi does not bind b (or the free vars of co) +We need (a) and (b) for the inserted binding to be correct. + +For the alternatives where we inject the binding, we can transfer +all x's OccInfo to b. And that is the point. + +Notice that + * The deliberate shadowing of 'x'. + * That (a) rapidly becomes false, so no bindings are injected. + +The reason for doing these transformations /here in the occurrence +analyser/ is because it allows us to adjust the OccInfo for 'x' and +'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If instead we do this in the Simplifier, we don't know whether 'x' + is used in ri, so we are forced to pessimistically zap b's OccInfo + even though it is typically dead (ie neither it nor x appear in + the ri). There's nothing actually wrong with zapping it, except + that it's kind of nice to know which variables are dead. My nose + tells me to keep this information as robustly as possible. + +The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding +{x=b}; it's Nothing if the binder-swap doesn't happen. + +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Note [Binder swap on GlobalId scrutinees] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the scrutinee is a GlobalId we must take care in two ways + + i) In order to *know* whether 'x' occurs free in the RHS, we need its + occurrence info. BUT, we don't gather occurrence info for + GlobalIds. That's the reason for the (small) occ_gbl_scrut env in + OccEnv is for: it says "gather occurrence info for these". + + ii) We must call localiseId on 'x' first, in case it's a GlobalId, or + has an External Name. See, for example, SimplEnv Note [Global Ids in + the substitution]. + +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> let x = cb in ...x... } + +Core Lint never expects to find an *occurrence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See #5028. + +NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier +doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. + +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressions when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. The straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. +-} + +mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) +-- Does three things: a) makes the occ_one_shots = OccVanilla +-- b) extends the GlobalScruts if possible +-- c) returns a proxy mapping, binding the scrutinee +-- to the case binder, if possible +mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr + = case stripTicksTopE (const True) scrut of + Var v -> add_scrut v case_bndr' + Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) + -- See Note [Case of cast] + _ -> (env { occ_encl = OccVanilla }, Nothing) + + where + add_scrut v rhs + | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing) + | otherwise = ( env { occ_encl = OccVanilla + , occ_gbl_scrut = pe `extendVarSet` v } + , Just (localise v, rhs) ) + -- ToDO: this isGlobalId stuff is a TEMPORARY FIX + -- to avoid the binder-swap for GlobalIds + -- See #16346 + + case_bndr' = Var (zapIdOccInfo case_bndr) + -- See Note [Zap case binders in proxy bindings] + + -- Localise the scrut_var before shadowing it; we're making a + -- new binding for it, and it might have an External Name, or + -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] + -- Also we don't want any INLINE or NOINLINE pragmas! + localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) + (idType scrut_var) + +{- +************************************************************************ +* * +\subsection[OccurAnal-types]{OccEnv} +* * +************************************************************************ + +Note [UsageDetails and zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +On many occasions, we must modify all gathered occurrence data at once. For +instance, all occurrences underneath a (non-one-shot) lambda set the +'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but +that takes O(n) time and we will do this often---in particular, there are many +places where tail calls are not allowed, and each of these causes all variables +to get marked with 'NoTailCallInfo'. + +Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along +with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" +recording which variables have been zapped in some way. Zapping all occurrence +info then simply means setting the corresponding zapped set to the whole +'OccInfoEnv', a fast O(1) operation. +-} + +type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage + -- INVARIANT: never IAmDead + -- (Deadness is signalled by not being in the map at all) + +type ZappedSet = OccInfoEnv -- Values are ignored + +data UsageDetails + = UD { ud_env :: !OccInfoEnv + , ud_z_many :: ZappedSet -- apply 'markMany' to these + , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these + , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these + -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv + +instance Outputable UsageDetails where + ppr ud = ppr (ud_env (flattenUsageDetails ud)) + +------------------- +-- UsageDetails API + +andUDs, orUDs + :: UsageDetails -> UsageDetails -> UsageDetails +andUDs = combineUsageDetailsWith addOccInfo +orUDs = combineUsageDetailsWith orOccInfo + +andUDsList :: [UsageDetails] -> UsageDetails +andUDsList = foldl' andUDs emptyDetails + +mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc env id int_cxt arity + | isLocalId id + = singleton $ OneOcc { occ_in_lam = NotInsideLam + , occ_one_br = InOneBranch + , occ_int_cxt = int_cxt + , occ_tail = AlwaysTailCalled arity } + | id `elemVarSet` occ_gbl_scrut env + = singleton noOccInfo + + | otherwise + = emptyDetails + where + singleton info = emptyDetails { ud_env = unitVarEnv id info } + +addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails +addOneOcc ud id info + = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } + `alterZappedSets` (`delVarEnv` id) + where + plus_zapped old new = doZapping ud id old `addOccInfo` new + +addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails +addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set + -- It's OK to use nonDetFoldUFM here because addManyOccs commutes + +-- Add several occurrences, assumed not to be tail calls +addManyOccs :: Var -> UsageDetails -> UsageDetails +addManyOccs v u | isId v = addOneOcc u v noOccInfo + | otherwise = u + -- Give a non-committal binder info (i.e noOccInfo) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) + +delDetails :: UsageDetails -> Id -> UsageDetails +delDetails ud bndr + = ud `alterUsageDetails` (`delVarEnv` bndr) + +delDetailsList :: UsageDetails -> [Id] -> UsageDetails +delDetailsList ud bndrs + = ud `alterUsageDetails` (`delVarEnvList` bndrs) + +emptyDetails :: UsageDetails +emptyDetails = UD { ud_env = emptyVarEnv + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_no_tail = emptyVarEnv } + +isEmptyDetails :: UsageDetails -> Bool +isEmptyDetails = isEmptyVarEnv . ud_env + +markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails + :: UsageDetails -> UsageDetails +markAllMany ud = ud { ud_z_many = ud_env ud } +markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } +markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } + +zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo + +lookupDetails :: UsageDetails -> Id -> OccInfo +lookupDetails ud id + | isCoVar id -- We do not currently gather occurrence info (from types) + = noOccInfo -- for CoVars, so we must conservatively mark them as used + -- See Note [DoO not mark CoVars as dead] + | otherwise + = case lookupVarEnv (ud_env ud) id of + Just occ -> doZapping ud id occ + Nothing -> IAmDead + +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) + +{- Note [Do not mark CoVars as dead] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's obviously wrong to mark CoVars as dead if they are used. +Currently we don't traverse types to gather usase info for CoVars, +so we had better treat them as having noOccInfo. + +This showed up in #15696 we had something like + case eq_sel d of co -> ...(typeError @(...co...) "urk")... + +Then 'd' was substituted by a dictionary, so the expression +simpified to + case (Coercion ) of co -> ...(typeError @(...co...) "urk")... + +But then the "drop the case altogether" equation of rebuildCase +thought that 'co' was dead, and discarded the entire case. Urk! + +I have no idea how we managed to avoid this pitfall for so long! +-} + +------------------- +-- Auxiliary functions for UsageDetails implementation + +combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) + -> UsageDetails -> UsageDetails -> UsageDetails +combineUsageDetailsWith plus_occ_info ud1 ud2 + | isEmptyDetails ud1 = ud2 + | isEmptyDetails ud2 = ud1 + | otherwise + = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) + , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) + , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) + , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } + +doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo +doZapping ud var occ + = doZappingByUnique ud (varUnique var) occ + +doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo +doZappingByUnique ud uniq + = (if | in_subset ud_z_many -> markMany + | in_subset ud_z_in_lam -> markInsideLam + | otherwise -> id) . + (if | in_subset ud_z_no_tail -> markNonTailCalled + | otherwise -> id) + where + in_subset field = uniq `elemVarEnvByKey` field ud + +alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails +alterZappedSets ud f + = ud { ud_z_many = f (ud_z_many ud) + , ud_z_in_lam = f (ud_z_in_lam ud) + , ud_z_no_tail = f (ud_z_no_tail ud) } + +alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails +alterUsageDetails ud f + = ud { ud_env = f (ud_env ud) } + `alterZappedSets` f + +flattenUsageDetails :: UsageDetails -> UsageDetails +flattenUsageDetails ud + = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } + `alterZappedSets` const emptyVarEnv + +------------------- +-- See Note [Adjusting right-hand sides] +adjustRhsUsage :: Maybe JoinArity -> RecFlag + -> [CoreBndr] -- Outer lambdas, AFTER occ anal + -> UsageDetails -> UsageDetails +adjustRhsUsage mb_join_arity rec_flag bndrs usage + = maybe_mark_lam (maybe_drop_tails usage) + where + maybe_mark_lam ud | one_shot = ud + | otherwise = markAllInsideLam ud + maybe_drop_tails ud | exact_join = ud + | otherwise = markAllNonTailCalled ud + + one_shot = case mb_join_arity of + Just join_arity + | isRec rec_flag -> False + | otherwise -> all isOneShotBndr (drop join_arity bndrs) + Nothing -> all isOneShotBndr bndrs + + exact_join = case mb_join_arity of + Just join_arity -> bndrs `lengthIs` join_arity + _ -> False + +type IdWithOccInfo = Id + +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders +tagLamBinders usage binders + = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tagLamBinder usage binders + +tagLamBinder :: UsageDetails -- Of scope + -> Id -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binders +-- Used for lambda and case binders +-- It copes with the fact that lambda bindings can have a +-- stable unfolding, used for join points +tagLamBinder usage bndr + = (usage2, bndr') + where + occ = lookupDetails usage bndr + bndr' = setBinderOcc (markNonTailCalled occ) bndr + -- Don't try to make an argument into a join point + usage1 = usage `delDetails` bndr + usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) + -- This is effectively the RHS of a + -- non-join-point binding, so it's okay to use + -- addManyOccsSet, which assumes no tail calls + | otherwise = usage1 + +tagNonRecBinder :: TopLevelFlag -- At top level? + -> UsageDetails -- Of scope + -> CoreBndr -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binder + +tagNonRecBinder lvl usage binder + = let + occ = lookupDetails usage binder + will_be_join = decideJoinPointHood lvl usage [binder] + occ' | will_be_join = -- must already be marked AlwaysTailCalled + ASSERT(isAlwaysTailCalled occ) occ + | otherwise = markNonTailCalled occ + binder' = setBinderOcc occ' binder + usage' = usage `delDetails` binder + in + usage' `seq` (usage', binder') + +tagRecBinders :: TopLevelFlag -- At top level? + -> UsageDetails -- Of body of let ONLY + -> [(CoreBndr, -- Binder + UsageDetails, -- RHS usage details + [CoreBndr])] -- Lambdas in new RHS + -> (UsageDetails, -- Adjusted details for whole scope, + -- with binders removed + [IdWithOccInfo]) -- Tagged binders +-- Substantially more complicated than non-recursive case. Need to adjust RHS +-- details *before* tagging binders (because the tags depend on the RHSes). +tagRecBinders lvl body_uds triples + = let + (bndrs, rhs_udss, _) = unzip3 triples + + -- 1. Determine join-point-hood of whole group, as determined by + -- the *unadjusted* usage details + unadj_uds = foldr andUDs body_uds rhs_udss + will_be_joins = decideJoinPointHood lvl unadj_uds bndrs + + -- 2. Adjust usage details of each RHS, taking into account the + -- join-point-hood decision + rhs_udss' = map adjust triples + adjust (bndr, rhs_uds, rhs_bndrs) + = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds + where + -- Can't use willBeJoinId_maybe here because we haven't tagged the + -- binder yet (the tag depends on these adjustments!) + mb_join_arity + | will_be_joins + , let occ = lookupDetails unadj_uds bndr + , AlwaysTailCalled arity <- tailCallInfo occ + = Just arity + | otherwise + = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if + Nothing -- we are making join points! + + -- 3. Compute final usage details from adjusted RHS details + adj_uds = foldr andUDs body_uds rhs_udss' + + -- 4. Tag each binder with its adjusted details + bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr + | bndr <- bndrs ] + + -- 5. Drop the binders from the adjusted details and return + usage' = adj_uds `delDetailsList` bndrs + in + (usage', bndrs') + +setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setBinderOcc occ_info bndr + | isTyVar bndr = bndr + | isExportedId bndr = if isManyOccs (idOccInfo bndr) + then bndr + else setIdOccInfo bndr noOccInfo + -- Don't use local usage info for visible-elsewhere things + -- BUT *do* erase any IAmALoopBreaker annotation, because we're + -- about to re-generate it and it shouldn't be "sticky" + + | otherwise = setIdOccInfo bndr occ_info + +-- | Decide whether some bindings should be made into join points or not. +-- Returns `False` if they can't be join points. Note that it's an +-- all-or-nothing decision, as if multiple binders are given, they're +-- assumed to be mutually recursive. +-- +-- It must, however, be a final decision. If we say "True" for 'f', +-- and then subsequently decide /not/ make 'f' into a join point, then +-- the decision about another binding 'g' might be invalidated if (say) +-- 'f' tail-calls 'g'. +-- +-- See Note [Invariants on join points] in GHC.Core. +decideJoinPointHood :: TopLevelFlag -> UsageDetails + -> [CoreBndr] + -> Bool +decideJoinPointHood TopLevel _ _ + = False +decideJoinPointHood NotTopLevel usage bndrs + | isJoinId (head bndrs) + = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> + ppr bndrs) + all_ok + | otherwise + = all_ok + where + -- See Note [Invariants on join points]; invariants cited by number below. + -- Invariant 2 is always satisfiable by the simplifier by eta expansion. + all_ok = -- Invariant 3: Either all are join points or none are + all ok bndrs + + ok bndr + | -- Invariant 1: Only tail calls, all same join arity + AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = True + + | otherwise + = False + + ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans + ok_rule join_arity (Rule { ru_args = args }) + = args `lengthIs` join_arity + -- Invariant 1 as applied to LHSes of rules + + -- ok_unfolding returns False if we should /not/ convert a non-join-id + -- into a join-id, even though it is AlwaysTailCalled + ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) + = not (isStableSource src && join_arity > joinRhsArity rhs) + ok_unfolding _ (DFunUnfolding {}) + = False + ok_unfolding _ _ + = True + +willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity +willBeJoinId_maybe bndr + = case tailCallInfo (idOccInfo bndr) of + AlwaysTailCalled arity -> Just arity + _ -> isJoinId_maybe bndr + + +{- Note [Join points and INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let g = \x. not -- Arity 1 + {-# INLINE g #-} + in case x of + A -> g True True + B -> g True False + C -> blah2 + +Here 'g' is always tail-called applied to 2 args, but the stable +unfolding captured by the INLINE pragma has arity 1. If we try to +convert g to be a join point, its unfolding will still have arity 1 +(since it is stable, and we don't meddle with stable unfoldings), and +Lint will complain (see Note [Invariants on join points], (2a), in +GHC.Core. #13413. + +Moreover, since g is going to be inlined anyway, there is no benefit +from making it a join point. + +If it is recursive, and uselessly marked INLINE, this will stop us +making it a join point, which is annoying. But occasionally +(notably in class methods; see Note [Instances and loop breakers] in +TcInstDcls) we mark recursive things as INLINE but the recursion +unravels; so ignoring INLINE pragmas on recursive things isn't good +either. + +See Invariant 2a of Note [Invariants on join points] in GHC.Core + + +************************************************************************ +* * +\subsection{Operations over OccInfo} +* * +************************************************************************ +-} + +markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo + +markMany IAmDead = IAmDead +markMany occ = ManyOccs { occ_tail = occ_tail occ } + +markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } +markInsideLam occ = occ + +markNonTailCalled IAmDead = IAmDead +markNonTailCalled occ = occ { occ_tail = NoTailCallInfo } + +addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo + +addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` + tailCallInfo a2 } + -- Both branches are at least One + -- (Argument is never IAmDead) + +-- (orOccInfo orig new) is used +-- when combining occurrence info from branches of a case + +orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 + , occ_tail = tail1 }) + (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 + , occ_tail = tail2 }) + = OneOcc { occ_one_br = MultipleBranches -- because it occurs in both branches + , occ_in_lam = in_lam1 `mappend` in_lam2 + , occ_int_cxt = int_cxt1 `mappend` int_cxt2 + , occ_tail = tail1 `andTailCallInfo` tail2 } + +orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` + tailCallInfo a2 } + +andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo +andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) + | arity1 == arity2 = info +andTailCallInfo _ _ = NoTailCallInfo diff --git a/compiler/GHC/Core/Op/Tidy.hs b/compiler/GHC/Core/Op/Tidy.hs --- a/compiler/GHC/Core/Op/Tidy.hs +++ b/compiler/GHC/Core/Op/Tidy.hs @@ -19,16 +19,16 @@ import GHC.Core import GHC.Core.Seq ( seqUnfolding ) -import Id -import IdInfo -import Demand ( zapUsageEnvSig ) -import Type( tidyType, tidyVarBndr ) -import Coercion( tidyCo ) -import Var -import VarEnv -import UniqFM -import Name hiding (tidyNameOcc) -import SrcLoc +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( zapUsageEnvSig ) +import GHC.Core.Type ( tidyType, tidyVarBndr ) +import GHC.Core.Coercion ( tidyCo ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Types.Name hiding (tidyNameOcc) +import GHC.Types.SrcLoc import Maybes import Data.List @@ -191,7 +191,7 @@ -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. -- But: Remove the usage demand here - -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap) + -- (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Op.WorkWrap) -- -- Similarly arity info for eta expansion in CorePrep -- Don't attempt to recompute arity here; this is just tidying! @@ -277,7 +277,7 @@ Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we -must preserve this info in inlinings. See Note [The oneShot function] in MkId. +must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make. This applies to lambda binders only, hence it is stored in IfaceLamBndr. -} diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/PatSyn.hs @@ -0,0 +1,484 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[PatSyn]{@PatSyn@: Pattern synonyms} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.PatSyn ( + -- * Main data types + PatSyn, mkPatSyn, + + -- ** Type deconstruction + patSynName, patSynArity, patSynIsInfix, + patSynArgs, + patSynMatcher, patSynBuilder, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, + patSynInstArgTys, patSynInstResTy, patSynFieldLabels, + patSynFieldType, + + updatePatSynIds, pprPatSynType + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Type +import GHC.Core.TyCo.Ppr +import GHC.Types.Name +import Outputable +import GHC.Types.Unique +import Util +import GHC.Types.Basic +import GHC.Types.Var +import GHC.Types.FieldLabel + +import qualified Data.Data as Data +import Data.Function +import Data.List (find) + +{- +************************************************************************ +* * +\subsection{Pattern synonyms} +* * +************************************************************************ +-} + +-- | Pattern Synonym +-- +-- See Note [Pattern synonym representation] +-- See Note [Pattern synonym signature contexts] +data PatSyn + = MkPatSyn { + psName :: Name, + psUnique :: Unique, -- Cached from Name + + psArgs :: [Type], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + psFieldLabels :: [FieldLabel], -- List of fields for a + -- record pattern synonym + -- INVARIANT: either empty if no + -- record pat syn or same length as + -- psArgs + + -- Universally-quantified type variables + psUnivTyVars :: [TyVarBinder], + + -- Required dictionaries (may mention psUnivTyVars) + psReqTheta :: ThetaType, + + -- Existentially-quantified type vars + psExTyVars :: [TyVarBinder], + + -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) + psProvTheta :: ThetaType, + + -- Result type + psResultTy :: Type, -- Mentions only psUnivTyVars + -- See Note [Pattern synonym result type] + + -- See Note [Matchers and builders for pattern synonyms] + psMatcher :: (Id, Bool), + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + + psBuilder :: Maybe (Id, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + } + +{- Note [Pattern synonym signature contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a pattern synonym signature we write + pattern P :: req => prov => t1 -> ... tn -> res_ty + +Note that the "required" context comes first, then the "provided" +context. Moreover, the "required" context must not mention +existentially-bound type variables; that is, ones not mentioned in +res_ty. See lots of discussion in #10928. + +If there is no "provided" context, you can omit it; but you +can't omit the "required" part (unless you omit both). + +Example 1: + pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) + pattern P1 x = Just (3,x) + + We require (Num a, Eq a) to match the 3; there is no provided + context. + +Example 2: + data T2 where + MkT2 :: (Num a, Eq a) => a -> a -> T2 + + pattern P2 :: () => (Num a, Eq a) => a -> T2 + pattern P2 x = MkT2 3 x + + When we match against P2 we get a Num dictionary provided. + We can use that to check the match against 3. + +Example 3: + pattern P3 :: Eq a => a -> b -> T3 b + + This signature is illegal because the (Eq a) is a required + constraint, but it mentions the existentially-bound variable 'a'. + You can see it's existential because it doesn't appear in the + result type (T3 b). + +Note [Pattern synonym result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b = MkT b a + + pattern P :: a -> T [a] Bool + pattern P x = MkT True [x] + +P's psResultTy is (T a Bool), and it really only matches values of +type (T [a] Bool). For example, this is ill-typed + + f :: T p q -> String + f (P x) = "urk" + +This is different to the situation with GADTs: + + data S a where + MkS :: Int -> S Bool + +Now MkS (and pattern synonyms coming from MkS) can match a +value of type (S a), not just (S Bool); we get type refinement. + +That in turn means that if you have a pattern + + P x :: T [ty] Bool + +it's not entirely straightforward to work out the instantiation of +P's universal tyvars. You have to /match/ + the type of the pattern, (T [ty] Bool) +against + the psResultTy for the pattern synonym, T [a] Bool +to get the instantiation a := ty. + +This is very unlike DataCons, where univ tyvars match 1-1 the +arguments of the TyCon. + +Side note: I (SG) get the impression that instantiated return types should +generate a *required* constraint for pattern synonyms, rather than a *provided* +constraint like it's the case for GADTs. For example, I'd expect these +declarations to have identical semantics: + + pattern Just42 :: Maybe Int + pattern Just42 = Just 42 + + pattern Just'42 :: (a ~ Int) => Maybe a + pattern Just'42 = Just 42 + +The latter generates the proper required constraint, the former does not. +Also rather different to GADTs is the fact that Just42 doesn't have any +universally quantified type variables, whereas Just'42 or MkS above has. + +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + requires: (Eq t, Num t) + provides: (Show (Maybe t), Ord b) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) + psResultTy = T (Maybe t) + +Note [Matchers and builders for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym P, we generate + + * a "matcher" function, used to desugar uses of P in patterns, + which implements pattern matching + + * A "builder" function (for bidirectional pattern synonyms only), + used to desugar uses of P in expressions, which constructs P-values. + +For the above example, the matcher function has type: + + $mP :: forall (r :: ?) t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> (Void# -> r) + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail + = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail Void# + +Notice that the return type 'r' has an open kind, so that it can +be instantiated by an unboxed type; for example where we see + f (P x) = 3# + +The extra Void# argument for the failure continuation is needed so that +it is lazy even when the result type is unboxed. + +For the same reason, if the pattern has no arguments, an extra Void# +argument is added to the success continuation as well. + +For *bidirectional* pattern synonyms, we also generate a "builder" +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) + => b -> T (Maybe t) + $bP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the builder since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. + +Note [Builder for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For bidirectional pattern synonyms that have no arguments and have an +unboxed type, we add an extra Void# argument to the builder, else it +would be a top-level declaration with an unboxed type. + + pattern P = 0# + + $bP :: Void# -> Int# + $bP _ = 0# + +This means that when typechecking an occurrence of P in an expression, +we must remember that the builder has this void argument. This is +done by TcPatSyn.patSynBuilderOcc. + +Note [Pattern synonyms and the data type Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type of a pattern synonym is of the form (See Note +[Pattern synonym signatures] in TcSigs): + + forall univ_tvs. req => forall ex_tvs. prov => ... + +We cannot in general represent this by a value of type Type: + + - if ex_tvs is empty, then req and prov cannot be distinguished from + each other + - if req is empty, then univ_tvs and ex_tvs cannot be distinguished + from each other, and moreover, prov is seen as the "required" context + (as it is the only context) + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = patSynName + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts + -> [Type] -- ^ Original arguments + -> Type -- ^ Original result type + -> (Id, Bool) -- ^ Name of matcher + -> Maybe (Id, Bool) -- ^ Name of builder + -> [FieldLabel] -- ^ Names of fields for + -- a record pattern synonym + -> PatSyn + -- NB: The univ and ex vars are both in TyBinder form and TyVar form for + -- convenience. All the TyBinders should be Named! +mkPatSyn name declared_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + orig_args + orig_res_ty + matcher builder field_labels + = MkPatSyn {psName = name, psUnique = getUnique name, + psUnivTyVars = univ_tvs, + psExTyVars = ex_tvs, + psProvTheta = prov_theta, psReqTheta = req_theta, + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psResultTy = orig_res_ty, + psMatcher = matcher, + psBuilder = builder, + psFieldLabels = field_labels + } + +-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification +patSynName :: PatSyn -> Name +patSynName = psName + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +patSynArgs :: PatSyn -> [Type] +patSynArgs = psArgs + +patSynFieldLabels :: PatSyn -> [FieldLabel] +patSynFieldLabels = psFieldLabels + +-- | Extract the type for any given labelled field of the 'DataCon' +patSynFieldType :: PatSyn -> FieldLabelString -> Type +patSynFieldType ps label + = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) + +patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] +patSynUnivTyVarBinders = psUnivTyVars + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars ps = binderVars (psExTyVars ps) + +patSynExTyVarBinders :: PatSyn -> [TyVarBinder] +patSynExTyVarBinders = psExTyVars + +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) +patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psResultTy = res_ty }) + = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) + +patSynMatcher :: PatSyn -> (Id,Bool) +patSynMatcher = psMatcher + +patSynBuilder :: PatSyn -> Maybe (Id, Bool) +patSynBuilder = psBuilder + +updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) + = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } + where + tidy_pr (id, dummy) = (tidy_fn id, dummy) + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = binderVars (univ_tvs ++ ex_tvs) + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psResultTy = res_ty }) + inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + substTyWith (binderVars univ_tvs) inst_tys res_ty + +-- | Print the type of a pattern synonym. The foralls are printed explicitly +pprPatSynType :: PatSyn -> SDoc +pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psResultTy = orig_res_ty }) + = sep [ pprForAll univ_tvs + , pprThetaArrowTy req_theta + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , pprType sigma_ty ] + where + sigma_ty = mkForAllTys ex_tvs $ + mkInvisFunTys prov_theta $ + mkVisFunTys orig_args orig_res_ty + insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/GHC/Core/PatSyn.hs-boot b/compiler/GHC/Core/PatSyn.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/PatSyn.hs-boot @@ -0,0 +1,13 @@ +module GHC.Core.PatSyn where + +import GHC.Types.Basic (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) +import GHC.Types.Var (TyVar) +import GHC.Types.Name (Name) + +data PatSyn + +patSynArity :: PatSyn -> Arity +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +patSynExTyVars :: PatSyn -> [TyVar] +patSynName :: PatSyn -> Name diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -21,23 +21,23 @@ import GHC.Core import GHC.Core.Stats (exprStats) -import Literal( pprLiteral ) -import Name( pprInfixName, pprPrefixName ) -import Var -import Id -import IdInfo -import Demand -import Cpr -import DataCon -import TyCon -import TyCoPpr -import Coercion -import BasicTypes +import GHC.Types.Literal( pprLiteral ) +import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion +import GHC.Types.Basic import Maybes import Util import Outputable import FastString -import SrcLoc ( pprUserRealSpan ) +import GHC.Types.SrcLoc ( pprUserRealSpan ) {- ************************************************************************ diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Predicate.hs @@ -0,0 +1,228 @@ +{- + +Describes predicates as they are considered by the solver. + +-} + +module GHC.Core.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 GHC.Core.Type +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Types.Var +import GHC.Core.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 [TyVar] [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) <- splitForAllTys 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 GHC.Core.TyCo.Rep +-- 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) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -31,7 +31,7 @@ import GhcPrelude import GHC.Core -- All of it -import Module ( Module, ModuleSet, elemModuleSet ) +import GHC.Types.Module ( Module, ModuleSet, elemModuleSet ) import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars @@ -40,24 +40,26 @@ , stripTicksTopT, stripTicksTopE , isJoinBind ) import GHC.Core.Ppr ( pprRules ) -import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst - , mkEmptyTCvSubst, substTy ) +import GHC.Core.Type as Type + ( Type, TCvSubst, extendTvSubst, extendCvSubst + , mkEmptyTCvSubst, substTy ) import TcType ( tcSplitTyConApp_maybe ) import TysWiredIn ( anyTypeOfKind ) -import Coercion +import GHC.Core.Coercion as Coercion import GHC.Core.Op.Tidy ( tidyRules ) -import Id -import IdInfo ( RuleInfo( RuleInfo ) ) -import Var -import VarEnv -import VarSet -import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) -import NameSet -import NameEnv -import UniqFM -import Unify ( ruleMatchTyKiX ) -import BasicTypes -import GHC.Driver.Session ( DynFlags ) +import GHC.Types.Id +import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.FM +import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) +import GHC.Types.Basic +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) +import GHC.Driver.Flags import Outputable import FastString import Maybes @@ -113,7 +115,7 @@ (d) Rules in the ExternalPackageTable. These can grow in response to lazy demand-loading of interfaces. -* At the moment (c) is carried in a reader-monad way by the CoreMonad. +* At the moment (c) is carried in a reader-monad way by the GHC.Core.Op.Monad. The HomePackageTable doesn't have a single RuleBase because technically we should only be able to "see" rules "below" this module; so we generate a RuleBase for (c) by combing rules from all the modules @@ -126,7 +128,7 @@ * So in the outer simplifier loop, we combine (b-d) into a single RuleBase, reading (b) from the ModGuts, - (c) from the CoreMonad, and + (c) from the GHC.Core.Op.Monad, and (d) from its mutable variable [Of course this means that we won't see new EPS rules that come in during a single simplifier iteration, but that probably does not @@ -181,7 +183,7 @@ ru_orphan = orph, ru_auto = is_auto, ru_local = is_local } where - -- Compute orphanhood. See Note [Orphans] in InstEnv + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined lhs_names = extendNameSet (exprsOrphNames args) fn @@ -329,7 +331,7 @@ - PrimOps and ClassOps are born with a bunch of rules inside the Id, even when they are imported - - The rules in PrelRules.builtinRules should be active even + - The rules in GHC.Core.Op.ConstantFold.builtinRules should be active even in the module defining the Id (when it's a LocalId), but the rules are kept in the global RuleBase @@ -509,7 +511,12 @@ 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 @@ -734,7 +741,7 @@ -- might substitute [a/b] in the template, and then erroneously -- succeed in matching what looks like the template variable 'a' against 3. --- The Var case follows closely what happens in Unify.match +-- The Var case follows closely what happens in GHC.Core.Unify.match match renv subst (Var v1) e2 = match_var renv subst v1 e2 @@ -1022,7 +1029,7 @@ On the other hand, where we are allowed to insert new cost into the tick scope, we can float them upwards to the rule application site. -cf Note [Notes in call patterns] in SpecConstr +cf Note [Notes in call patterns] in GHC.Core.Op.SpecConstr Note [Matching lets] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -13,15 +13,15 @@ import GhcPrelude import GHC.Core -import IdInfo -import Demand( seqDemand, seqStrictSig ) -import Cpr( seqCprSig ) -import BasicTypes( seqOccInfo ) -import VarSet( seqDVarSet ) -import Var( varType, tyVarKind ) -import Type( seqType, isTyVar ) -import Coercion( seqCo ) -import Id( Id, idInfo ) +import GHC.Types.Id.Info +import GHC.Types.Demand( seqDemand, seqStrictSig ) +import GHC.Types.Cpr( seqCprSig ) +import GHC.Types.Basic( seqOccInfo ) +import GHC.Types.Var.Set( seqDVarSet ) +import GHC.Types.Var( varType, tyVarKind ) +import GHC.Core.Type( seqType, isTyVar ) +import GHC.Core.Coercion( seqCo ) +import GHC.Types.Id( Id, idInfo ) -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the -- compiler diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -31,24 +31,24 @@ import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) import GHC.Core.Make ( FloatBind(..) ) import GHC.Core.Ppr ( pprCoreBindings, pprRules ) -import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) -import Literal ( Literal(LitString) ) -import Id -import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) -import Var ( isNonCoVarId ) -import VarSet -import VarEnv -import DataCon -import Demand( etaExpandStrictSig ) -import OptCoercion ( optCoercion ) -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) -import TyCon ( tyConArity ) +import GHC.Core.Op.OccurAnal( occurAnalyseExpr, occurAnalysePgm ) +import GHC.Types.Literal ( Literal(LitString) ) +import GHC.Types.Id +import GHC.Types.Id.Info ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) +import GHC.Types.Var ( isNonCoVarId ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.DataCon +import GHC.Types.Demand( etaExpandStrictSig ) +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.TyCon ( tyConArity ) import TysWiredIn import PrelNames -import BasicTypes -import Module ( Module ) +import GHC.Types.Basic +import GHC.Types.Module ( Module ) import ErrUtils import GHC.Driver.Session import Outputable @@ -469,7 +469,7 @@ post_inline_unconditionally | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] - | not active = False -- in SimplUtils + | not active = False -- in GHC.Core.Op.Simplify.Utils | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" | exprIsTrivial out_rhs = True @@ -489,7 +489,7 @@ {- Note [Exported Ids and trivial RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously do not want to unconditionally inline an Id that is exported. -In SimplUtils, Note [Top level and postInlineUnconditionally], we +In GHC.Core.Op.Simplify.Utils, Note [Top level and postInlineUnconditionally], we explain why we don't inline /any/ top-level things unconditionally, even trivial ones. But we do here! Why? In the simple optimiser @@ -673,7 +673,7 @@ However, we don't want to inline 'seq', which happens to also have a compulsory unfolding, so we only do this unfolding only for things -that are always-active. See Note [User-defined RULES for seq] in MkId. +that are always-active. See Note [User-defined RULES for seq] in GHC.Types.Id.Make. Note [Getting the map/coerce RULE to work] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -965,7 +965,7 @@ -- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers -- are unfolded late, but we really want to trigger case-of-known-constructor as -- early as possible. See also Note [Activation for data constructor wrappers] --- in MkId. +-- in GHC.Types.Id.Make. -- -- We also return the incoming InScopeSet, augmented with -- the binders from any [FloatBind] that we return @@ -1247,7 +1247,7 @@ -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype --- C.f. simplCast in Simplify.hs +-- C.f. simplCast in GHC.Core.Op.Simplify -- 'co' is always Representational -- If the returned coercion is Nothing, then it would have been reflexive pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -13,13 +13,13 @@ import GhcPrelude -import BasicTypes +import GHC.Types.Basic import GHC.Core import Outputable -import Coercion -import Var -import Type (Type, typeSize) -import Id (isJoinId) +import GHC.Core.Coercion +import GHC.Types.Var +import GHC.Core.Type(Type, typeSize) +import GHC.Types.Id (isJoinId) data CoreStats = CS { cs_tm :: !Int -- Terms , cs_ty :: !Int -- Types diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -43,22 +43,23 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils -import qualified Type -import qualified Coercion +import qualified GHC.Core.Type as Type +import qualified GHC.Core.Coercion as Coercion -- We are defining local versions -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Type hiding + ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import PrelNames -import VarSet -import VarEnv -import Id -import Name ( Name ) -import Var -import IdInfo -import UniqSupply +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Name ( Name ) +import GHC.Types.Var +import GHC.Types.Id.Info +import GHC.Types.Unique.Supply import Maybes import Util import Outputable @@ -79,9 +80,9 @@ -- -- Some invariants apply to how you use the substitution: -- --- 1. Note [The substitution invariant] in TyCoSubst +-- 1. Note [The substitution invariant] in GHC.Core.TyCo.Subst -- --- 2. Note [Substitutions apply only once] in TyCoSubst +-- 2. Note [Substitutions apply only once] in GHC.Core.TyCo.Subst data Subst = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ -- applying the substitution @@ -104,7 +105,7 @@ For a core Subst, which binds Ids as well, we make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] in TyCoSubst. +For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -339,7 +340,7 @@ -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only -- apply the substitution /once/: --- See Note [Substitutions apply only once] in TyCoSubst +-- See Note [Substitutions apply only once] in GHC.Core.TyCo.Subst -- -- Do *not* attempt to short-cut in the case of an empty substitution! -- See Note [Extending the Subst] diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE CPP #-} + +module GHC.Core.TyCo.FVs + ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, + + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsOfTypes, tyCoVarsOfTypesList, + deepTcvFolder, + + shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, + + shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCoDSet, + tyCoFVsOfCo, tyCoFVsOfCos, + tyCoVarsOfCoList, + + almostDevoidCoVarOfCo, + + -- Injective free vars + injectiveVarsOfType, injectiveVarsOfTypes, + invisibleVarsOfType, invisibleVarsOfTypes, + + -- No Free vars + noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + + -- * Well-scoped free variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Raw materials + Endo(..), runTyCoVars + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) + +import Data.Monoid as DM ( Endo(..), All(..) ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Types.Var +import FV + +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import Util +import Panic + +{- +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +{- Note [Shallow and deep free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Definitions + +* Shallow free variables of a type: the variables + affected by substitution. Specifically, the (TyVarTy tv) + and (CoVar cv) that appear + - In the type and coercions appearing in the type + - In shallow free variables of the kind of a Forall binder + but NOT in the kind of the /occurrences/ of a type variable. + +* Deep free variables of a type: shallow free variables, plus + the deep free variables of the kinds of those variables. + That is, deepFVs( t ) = closeOverKinds( shallowFVs( t ) ) + +Examples: + + Type Shallow Deep + --------------------------------- + (a : (k:Type)) {a} {a,k} + forall (a:(k:Type)). a {k} {k} + (a:k->Type) (b:k) {a,b} {a,b,k} +-} + + +{- Note [Free variables of types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns +a VarSet that is closed over the types of its variables. More precisely, + if S = tyCoVarsOfType( t ) + and (a:k) is in S + then tyCoVarsOftype( k ) is a subset of S + +Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. + +We could /not/ close over the kinds of the variable occurrences, and +instead do so at call sites, but it seems that we always want to do +so, so it's easiest to do it here. + +It turns out that getting the free variables of types is performance critical, +so we profiled several versions, exploring different implementation strategies. + +1. Baseline version: uses FV naively. Essentially: + + tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty + + This is not nice, because FV introduces some overhead to implement + determinism, and through its "interesting var" function, neither of which + we need here, so they are a complete waste. + +2. UnionVarSet version: instead of reusing the FV-based code, we simply used + VarSets directly, trying to avoid the overhead of FV. E.g.: + + -- FV version: + tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c + + -- UnionVarSet version: + tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) + + This looks deceptively similar, but while FV internally builds a list- and + set-generating function, the VarSet functions manipulate sets directly, and + the latter performs a lot worse than the naive FV version. + +3. Accumulator-style VarSet version: this is what we use now. We do use VarSet + as our data structure, but delegate the actual work to a new + ty_co_vars_of_... family of functions, which use accumulator style and the + "in-scope set" filter found in the internals of FV, but without the + determinism overhead. + +See #14880. + +Note [Closing over free variable kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over +free variable kinds. In previous GHC versions, this happened naively: whenever +we would encounter an occurrence of a free type variable, we would close over +its kind. This, however is wrong for two reasons (see #14880): + +1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then + we don't want to have to traverse k more than once. + +2. Correctness. Imagine we have forall k. b -> k, where b has + kind k, for some k bound in an outer scope. If we look at b's kind inside + the forall, we'll collect that k is free and then remove k from the set of + free variables. This is plain wrong. We must instead compute that b is free + and then conclude that b's kind is free. + +An obvious first approach is to move the closing-over-kinds from the +occurrences of a type variable to after finding the free vars - however, this +turns out to introduce performance regressions, and isn't even entirely +correct. + +In fact, it isn't even important *when* we close over kinds; what matters is +that we handle each type var exactly once, and that we do it in the right +context. + +So the next approach we tried was to use the "in-scope set" part of FV or the +equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to +say "don't bother with variables we have already closed over". This should work +fine in theory, but the code is complicated and doesn't perform well. + +But there is a simpler way, which is implemented here. Consider the two points +above: + +1. Efficiency: we now have an accumulator, so the second time we encounter 'a', + we'll ignore it, certainly not looking at its kind - this is why + pre-checking set membership before inserting ends up not only being faster, + but also being correct. + +2. Correctness: we have an "in-scope set" (I think we should call it it a + "bound-var set"), specifying variables that are bound by a forall in the type + we are traversing; we simply ignore these variables, certainly not looking at + their kind. + +So now consider: + + forall k. b -> k + +where b :: k->Type is free; but of course, it's a different k! When looking at +b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose +this is our first encounter with b; we want the free vars of its kind. But we +want to behave as if we took the free vars of its kind at the end; that is, +with no bound vars in scope. + +So the solution is easy. The old code was this: + + ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) + +Now all we need to do is take the free vars of tyVarKind v *with an empty +bound-var set*, thus: + +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) + ^^^^^^^^^^^ + +And that's it. This works because a variable is either bound or free. If it is bound, +then we won't look at it at all. If it is free, then all the variables free in its +kind are free -- regardless of whether some local variable has the same Unique. +So if we're looking at a variable occurrence at all, then all variables in its +kind are free. +-} + +{- ********************************************************************* +* * + Endo for free variables +* * +********************************************************************* -} + +{- Note [Acumulating parameter free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can use foldType to build an accumulating-parameter version of a +free-var finder, thus: + + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType folder ty) emptyVarSet + +Recall that + foldType :: TyCoFolder env a -> env -> Type -> a + + newtype Endo a = Endo (a -> a) -- In Data.Monoid + instance Monoid a => Monoid (Endo a) where + (Endo f) `mappend` (Endo g) = Endo (f.g) + + appEndo :: Endo a -> a -> a + appEndo (Endo f) x = f x + +So `mappend` for Endos is just function composition. + +It's very important that, after optimisation, we end up with +* an arity-three function +* that is strict in the accumulator + + fvs env (TyVarTy v) acc + | v `elemVarSet` env = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) + ... + +The "strict in the accumulator" part is to ensure that in the +AppTy equation we don't build a thunk for (fvs env t2 acc). + +The optimiser does do all this, but not very robustly. It depends +critially on the basic arity-2 function not being exported, so that +all its calls are visibly to three arguments. This analysis is +done by the Call Arity pass. + +TL;DR: check this regularly! +-} + +runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet +{-# INLINE runTyCoVars #-} +runTyCoVars f = appEndo f emptyVarSet + +noView :: Type -> Maybe Type +noView _ = Nothing + +{- ********************************************************************* +* * + Deep free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + +tyCoVarsOfType :: Type -> TyCoVarSet +tyCoVarsOfType ty = runTyCoVars (deep_ty ty) +-- Alternative: +-- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty) + +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) +-- Alternative: +-- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- See Note [Free variables of Coercions] +tyCoVarsOfCo co = runTyCoVars (deep_co co) + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) + +deep_ty :: Type -> Endo TyCoVarSet +deep_tys :: [Type] -> Endo TyCoVarSet +deep_co :: Coercion -> Endo TyCoVarSet +deep_cos :: [Coercion] -> Endo TyCoVarSet +(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet + +deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +deepTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_tcv is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + +{- ********************************************************************* +* * + Shallow free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + + +shallowTyCoVarsOfType :: Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty) + +shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet +shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys) + +shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet +shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) + +shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet +shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet +shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallow_ty :: Type -> Endo TyCoVarSet +shallow_tys :: [Type] -> Endo TyCoVarSet +shallow_co :: Coercion -> Endo TyCoVarSet +shallow_cos :: [Coercion] -> Endo TyCoVarSet +(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet + +shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +shallowTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole _ _ = mempty -- Ignore coercion holes + + +{- ********************************************************************* +* * + Free coercion variables +* * +********************************************************************* -} + + +{- Note [Finding free coercion varibles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here we are only interested in the free /coercion/ variables. +We can achieve this through a slightly differnet TyCo folder. + +Notice that we look deeply, into kinds. + +See #14880. +-} + +coVarsOfType :: Type -> CoVarSet +coVarsOfTypes :: [Type] -> CoVarSet +coVarsOfCo :: Coercion -> CoVarSet +coVarsOfCos :: [Coercion] -> CoVarSet + +coVarsOfType ty = runTyCoVars (deep_cv_ty ty) +coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) +coVarsOfCo co = runTyCoVars (deep_cv_co co) +coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) + +deep_cv_ty :: Type -> Endo CoVarSet +deep_cv_tys :: [Type] -> Endo CoVarSet +deep_cv_co :: Coercion -> Endo CoVarSet +deep_cv_cos :: [Coercion] -> Endo CoVarSet +(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet + +deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) +deepCoVarFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tyvar, tcf_covar = do_covar + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tyvar _ _ = mempty + -- This do_tyvar means we won't see any CoVars in this + -- TyVar's kind. This may be wrong; but it's the way it's + -- always been. And its awkward to change, because + -- the tyvar won't end up in the accumulator, so + -- we'd look repeatedly. Blargh. + + do_covar is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_cv_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_covar is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + + +{- ********************************************************************* +* * + Closing over kinds +* * +********************************************************************* -} + +------------- Closing over kinds ----------------- + +closeOverKinds :: TyCoVarSet -> TyCoVarSet +-- For each element of the input set, +-- add the deep free variables of its kind +closeOverKinds vs = nonDetFoldVarSet do_one vs vs + where + do_one v acc = appEndo (deep_ty (varType v)) acc + +{- --------------- Alternative version 1 (using FV) ------------ +closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet +-} + +{- ---------------- Alternative version 2 ------------- + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyCoVarSet -> TyCoVarSet +closeOverKinds vs + = go vs vs + where + go :: VarSet -- Work list + -> VarSet -- Accumulator, always a superset of wl + -> VarSet + go wl acc + | isEmptyVarSet wl = acc + | otherwise = go wl_kvs (acc `unionVarSet` wl_kvs) + where + k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc + wl_kvs = nonDetFoldVarSet k emptyVarSet wl + -- wl_kvs = union of shallow free vars of the kinds of wl + -- but don't bother to collect vars in acc + +-} + +{- ---------------- Alternative version 3 ------------- +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds vs = close_over_kinds vs emptyVarSet + + +close_over_kinds :: TyVarSet -- Work list + -> TyVarSet -- Accumulator + -> TyVarSet +-- Precondition: in any call (close_over_kinds wl acc) +-- for every tv in acc, the shallow kind-vars of tv +-- are either in the work list wl, or in acc +-- Postcondition: result is the deep free vars of (wl `union` acc) +close_over_kinds wl acc + = nonDetFoldVarSet do_one acc wl + where + do_one :: Var -> TyVarSet -> TyVarSet + -- (do_one v acc) adds v and its deep free-vars to acc + do_one v acc | v `elemVarSet` acc + = acc + | otherwise + = close_over_kinds (shallowTyCoVarsOfType (varType v)) $ + acc `extendVarSet` v +-} + + +{- ********************************************************************* +* * + The FV versions return deterministic results +* * +********************************************************************* -} + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsFV :: [TyVar] -> FV +closeOverKindsFV tvs = + mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministically ordered list. +closeOverKindsList :: [TyVar] -> [TyVar] +closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems + +-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty + +-- | `tyCoFVsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeList :: Type -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys + +-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with +-- other functions that compute free variables. +-- See Note [FV naming conventions] in FV. +-- +-- Eta-expanded because that makes it run faster (apparently) +-- See Note [FV eta expansion] in FV for explanation. +tyCoFVsOfType :: Type -> FV +-- See Note [Free variables of types] +tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) + | v `elemVarSet` bound_vars = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) + | otherwise = tyCoFVsOfType (tyVarKind v) f + emptyVarSet -- See Note [Closing over free variable kinds] + (v:acc_list, extendVarSet acc_set v) +tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc +tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc +tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc +tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc +tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc +tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc + +tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +-- Free vars of (forall b. ) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside + +tyCoFVsOfTypes :: [Type] -> FV +-- See Note [Free variables of types] +tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc +tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co + +tyCoFVsOfMCo :: MCoercion -> FV +tyCoFVsOfMCo MRefl = emptyFV +tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co + +tyCoFVsOfCo :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +-- See Note [Free variables of types] +tyCoFVsOfCo (Refl ty) fv_cand in_scope acc + = tyCoFVsOfType ty fv_cand in_scope acc +tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc + = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc +tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc + = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc +tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc + = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc + = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc + = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc + -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc + +tyCoFVsOfCoVar :: CoVar -> FV +tyCoFVsOfCoVar v fv_cand in_scope acc + = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + +tyCoFVsOfProv :: UnivCoProvenance -> FV +tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +tyCoFVsOfCos :: [Coercion] -> FV +tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc + + +----- Whether a covar is /Almost Devoid/ in a type or coercion ---- + +-- | Given a covar and a coercion, returns True if covar is almost devoid in +-- the coercion. That is, covar can only appear in Refl and GRefl. +-- See last wrinkle in Note [Unused coercion variable in ForAllCo] in GHC.Core.Coercion +almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool +almostDevoidCoVarOfCo cv co = + almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool +almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and +almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (AppCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv + = almost_devoid_co_var_of_co kind_co cv + && (v == cv || almost_devoid_co_var_of_co co cv) +almost_devoid_co_var_of_co (FunCo _ co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv +almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv +almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv + = almost_devoid_co_var_of_prov p cv + && almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_type t2 cv +almost_devoid_co_var_of_co (SymCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (TransCo co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (NthCo _ _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (LRCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (InstCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (KindCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (SubCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv + +almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool +almost_devoid_co_var_of_cos [] _ = True +almost_devoid_co_var_of_cos (co:cos) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_cos cos cv + +almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool +almost_devoid_co_var_of_prov (PhantomProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (ProofIrrelProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (PluginProv _) _ = True + +almost_devoid_co_var_of_type :: Type -> CoVar -> Bool +almost_devoid_co_var_of_type (TyVarTy _) _ = True +almost_devoid_co_var_of_type (TyConApp _ tys) cv + = almost_devoid_co_var_of_types tys cv +almost_devoid_co_var_of_type (LitTy {}) _ = True +almost_devoid_co_var_of_type (AppTy fun arg) cv + = almost_devoid_co_var_of_type fun cv + && almost_devoid_co_var_of_type arg cv +almost_devoid_co_var_of_type (FunTy _ arg res) cv + = almost_devoid_co_var_of_type arg cv + && almost_devoid_co_var_of_type res cv +almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv + = almost_devoid_co_var_of_type (varType v) cv + && (v == cv || almost_devoid_co_var_of_type ty cv) +almost_devoid_co_var_of_type (CastTy ty co) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_type (CoercionTy co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool +almost_devoid_co_var_of_types [] _ = True +almost_devoid_co_var_of_types (ty:tys) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_types tys cv + + + +{- ********************************************************************* +* * + Injective free vars +* * +********************************************************************* -} + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- +-- For example, if @F@ is a non-injective type family, then: +-- +-- @ +-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} +-- @ +-- +-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. +-- More formally, if +-- @a@ is in @'injectiveVarsOfType' ty@ +-- and @S1(ty) ~ S2(ty)@, +-- then @S1(a) ~ S2(a)@, +-- where @S1@ and @S2@ are arbitrary substitutions. +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in FamInst. + -> Type -> FV +injectiveVarsOfType look_under_tfs = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = + case tyConInjectivityInfo tc of + Injective inj + | look_under_tfs || not (isTypeFamilyTyCon tc) + -> mapUnionFV go $ + filterByList (inj ++ repeat True) tys + -- Oversaturated arguments to a tycon are + -- always injective, hence the repeat True + _ -> emptyFV + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfTypes :: Bool -- ^ look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in FamInst. + -> [Type] -> FV +injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) + + +{- ********************************************************************* +* * + Invisible vars +* * +********************************************************************* -} + + +-- | Returns the set of variables that are used invisibly anywhere within +-- the given type. A variable will be included even if it is used both visibly +-- and invisibly. An invisible use site includes: +-- * In the kind of a variable +-- * In the kind of a bound variable in a forall +-- * In a coercion +-- * In a Specified or Inferred argument to a function +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep +invisibleVarsOfType :: Type -> FV +invisibleVarsOfType = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` + invisibleVarsOfTypes visibles + where (invisibles, visibles) = partitionInvisibleTypes tc tys + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty + go LitTy{} = emptyFV + go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty + go (CoercionTy co) = tyCoFVsOfCo co + +-- | Like 'invisibleVarsOfType', but for many types. +invisibleVarsOfTypes :: [Type] -> FV +invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType + + +{- ********************************************************************* +* * + No free vars +* * +********************************************************************* -} + +nfvFolder :: TyCoFolder TyCoVarSet DM.All +nfvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is tv = All (tv `elemVarSet` is) + do_hole _ _ = All True -- I'm unsure; probably never happens + do_bndr is tv _ = is `extendVarSet` tv + +nfv_ty :: Type -> DM.All +nfv_tys :: [Type] -> DM.All +nfv_co :: Coercion -> DM.All +(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet + +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType ty = DM.getAll (nfv_ty ty) + +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys) + +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo co = getAll (nfv_co co) + + +{- ********************************************************************* +* * + scopedSort +* * +********************************************************************* -} + +{- Note [ScopedSort] +~~~~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given [ a::k, k::*, b::k ] +-- it'll return a well-scoped list [ k::*, a::k, b::k ] +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in GHC.Rename.Types + +scopedSort :: [TyCoVar] -> [TyCoVar] +scopedSort = go [] [] + where + go :: [TyCoVar] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [TyCoVar] -- yet to be sorted + -> [TyCoVar] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: TyCoVar -- var to insert + -> [TyCoVar] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([TyCoVar], [TyCoVarSet]) -- augmented lists + insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) + insert tv (a:as) (fvs:fvss) + | tv `elemVarSet` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `unionVarSet` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) + where + fv_tv = tyCoVarsOfType (tyVarKind tv) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -0,0 +1,341 @@ +-- | Pretty-printing types and coercions. +module GHC.Core.TyCo.Ppr + ( + -- * Precedence + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + + -- * Pretty-printing types + pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX, + pprTypeApp, pprTCvBndr, pprTCvBndrs, + pprSigmaType, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + pprDataCons, pprWithExplicitKindsWhen, + pprWithTYPE, pprSourceTyCon, + + + -- * Pretty-printing coercions + pprCo, pprParendCo, + + debugPprType, + + -- * Pretty-printing 'TyThing's + pprTyThingCategory, pprShortTyThing, + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.CoreToIface + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) + +import {-# SOURCE #-} GHC.Core.DataCon + ( dataConFullSig , dataConUserTyVarBinders + , DataCon ) + +import {-# SOURCE #-} GHC.Core.Type + ( isLiftedTypeKind ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs +import GHC.Core.Class +import GHC.Types.Var + +import GHC.Iface.Type + +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import Outputable +import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen ) + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note that any function which pretty-prints a @Type@ first converts the @Type@ +to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. + +See Note [Precedence in types] in GHC.Types.Basic. +-} + +-------------------------------------------------------- +-- When pretty-printing types, we convert to IfaceType, +-- and pretty-print that. +-- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing +-------------------------------------------------------- + +pprType, pprParendType, pprTidiedType :: Type -> SDoc +pprType = pprPrecType topPrec +pprParendType = pprPrecType appPrec + +-- already pre-tidied +pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet + +pprPrecType :: PprPrec -> Type -> SDoc +pprPrecType = pprPrecTypeX emptyTidyEnv + +pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc +pprPrecTypeX env prec ty + = getPprStyle $ \sty -> + if debugStyle sty -- Use debugPprType when in + then debug_ppr_ty prec ty -- when in debug-style + else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) + -- NB: debug-style is used for -dppr-debug + -- dump-style is used for -ddump-tc-trace etc + +pprTyLit :: TyLit -> SDoc +pprTyLit = pprIfaceTyLit . toIfaceTyLit + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv + +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceTypeX to +-- leave them as IfaceFreeTyVar. This is super-important +-- for debug printing. +tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + where + env' = tidyFreeTyCoVars env free_tcvs + free_tcvs = tyCoVarsOfTypeWellScoped ty + +------------ +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) +pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) + +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty co sty + | userStyle sty = tidyToIfaceCo co + | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceCo :: Coercion -> IfaceCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceCoercionX to +-- leave them as IfaceFreeCoVar. This is super-important +-- for debug printing. +tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfCoList co +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta = pprIfaceContext topPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType + +------------------ +pprSigmaType :: Type -> SDoc +pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType + +pprForAll :: [TyCoVarBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) + +-- | Print a user-level forall; see Note [When to print foralls] in this module. +pprUserForAll :: [TyCoVarBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr + +pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) + +pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +-- Here we do not go via IfaceType, because the duplication with +-- pprIfaceTvBndr is minimal, and the loss of uniques etc in +-- debug printing is disastrous +pprTyVar tv + | isLiftedTypeKind kind = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) + where + kind = tyVarKind tv + +----------------- +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty topPrec ty + +debug_ppr_ty :: PprPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ppr tv -- With -dppr-debug we get (tv :: kind) + +debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + = maybeParen prec funPrec $ + sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] + where + arrow = case af of + VisArg -> text "->" + InvisArg -> text "=>" + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec appPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) + +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec topPrec $ + hang (debug_ppr_ty topPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec funPrec $ + hang (text "forall" <+> fsep (map ppr tvs) <> dot) + -- The (map ppr tvs) will print kind-annotated + -- tvs, because we are (usually) in debug-style + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTCvBndr. + +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + user_bndrs = dataConUserTyVarBinders dc + forAllDoc = pprUserForAll user_bndrs + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType arg_tys) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys + = pprIfaceTypeApp topPrec (toIfaceTyCon tc) + (toIfaceTcArgs tc tys) + -- TODO: toIfaceTcArgs seems rather wasteful here + +------------------ +-- | Display all kind information (with @-fprint-explicit-kinds@) when the +-- provided 'Bool' argument is 'True'. +-- See @Note [Kind arguments in error messages]@ in TcErrors. +pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc +pprWithExplicitKindsWhen b + = updSDocContext $ \ctx -> + if b then ctx { sdocPrintExplicitKinds = True } + else ctx + +-- | This variant preserves any use of TYPE in a type, effectively +-- locally setting -fprint-explicit-runtime-reps. +pprWithTYPE :: Type -> SDoc +pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $ + ppr ty + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -0,0 +1,10 @@ +module GHC.Core.TyCo.Ppr where + +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) +import Outputable + +pprType :: Type -> SDoc +pprKind :: Kind -> SDoc +pprCo :: Coercion -> SDoc +pprTyLit :: TyLit -> SDoc + diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -0,0 +1,1910 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + GHC.Core.Class + GHC.Core.Coercion.Axiom + GHC.Core.TyCon imports GHC.Core.{Class, Coercion.Axiom} + GHC.Core.TyCo.Rep imports GHC.Core.{Class, Coercion.Axiom, TyCon} + GHC.Core.TyCo.Ppr imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.FVs imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst imports GHC.Core.TyCo.{Rep, FVs, Ppr} + GHC.Core.TyCo.Tidy imports GHC.Core.TyCo.{Rep, FVs} + TysPrim imports GHC.Core.TyCo.Rep ( including mkTyConTy ) + GHC.Core.Coercion imports GHC.Core.Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} + +module GHC.Core.TyCo.Rep ( + TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, + + -- * Types + Type( TyVarTy, AppTy, TyConApp, ForAllTy + , LitTy, CastTy, CoercionTy + , FunTy, ft_arg, ft_res, ft_af + ), -- Export the type synonym FunTy too + + TyLit(..), + KindOrType, Kind, + KnotTied, + PredType, ThetaType, -- Synonyms + ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + + -- * Coercions + Coercion(..), + UnivCoProvenance(..), + CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar, + CoercionN, CoercionR, CoercionP, KindCoercion, + MCoercion(..), MCoercionR, MCoercionN, + + -- * Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + mkForAllTy, mkForAllTys, + mkPiTy, mkPiTys, + + -- * Functions over binders + TyCoBinder(..), TyCoVarBinder, TyBinder, + binderVar, binderVars, binderType, binderArgFlag, + delBinderVar, + isInvisibleArgFlag, isVisibleArgFlag, + isInvisibleBinder, isVisibleBinder, + isTyBinder, isNamedBinder, + + -- * Functions over coercions + pickLR, + + -- ** Analyzing types + TyCoFolder(..), foldTyCo, + + -- * Sizes + typeSize, coercionSize, provSize + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) + + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName ) + +-- friends: +import GHC.Iface.Type +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom + +-- others +import GHC.Types.Basic ( LeftOrRight(..), pickLR ) +import Outputable +import FastString +import Util + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +It is also SOURCE-imported into Name.hs + + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See 'TcEnv' for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +pprShortTyThing :: TyThing -> SDoc +-- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" + + +{- ********************************************************************** +* * + Type +* * +********************************************************************** -} + +-- | The key representation of types within the compiler + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', + -- must be another 'AppTy', or 'TyVarTy' + -- See Note [Respecting definitional equality] (EQ1) about the + -- no 'CastTy' requirement + -- + -- 2) Argument type + + | TyConApp + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy + {-# UNPACK #-} !TyCoVarBinder + Type -- ^ A Π type. + -- INVARIANT: If the binder is a coercion variable, it must + -- be mentioned in the Type. See + -- Note [Unused coercion variable in ForAllTy] + + | FunTy -- ^ t1 -> t2 Very common, so an important special case + -- See Note [Function types] + { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + KindCoercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never reflexive + -- INVARIANT: The Type is not a CastTy (use TransCo instead) + -- INVARIANT: The Type is not a ForAllTy over a type variable + -- See Note [Respecting definitional equality] (EQ2), (EQ3), (EQ4) + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving Data.Data + +instance Outputable Type where + ppr = pprType + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data) + +instance Outputable TyLit where + ppr = pprTyLit + +{- Note [Function types] +~~~~~~~~~~~~~~~~~~~~~~~~ +FFunTy is the constructor for a function type. Lots of things to say +about it! + +* FFunTy is the data constructor, meaning "full function type". + +* The function type constructor (->) has kind + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep + mkTyConApp ensure that we convert a saturated application + TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 + dropping the 'r1' and 'r2' arguments; they are easily recovered + from 't1' and 't2'. + +* The ft_af field says whether or not this is an invisible argument + VisArg: t1 -> t2 Ordinary function type + InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, + i.e. t1 :: Constraint + See Note [Types for coercions, predicates, and evidence] + + This visibility info makes no difference in Core; it matters + only when we regard the type as a Haskell source type. + +* FunTy is a (unidirectional) pattern synonym that allows + positional pattern matching (FunTy arg res), ignoring the + ArgFlag. +-} + +{- ----------------------- + Commented out until the pattern match + checker can handle it; see #16185 + + For now we use the CPP macro #define FunTy FFunTy _ + (see HsVersions.h) to allow pattern matching on a + (positional) FunTy constructor. + +{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp + , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} + +-- | 'FunTy' is a (uni-directional) pattern synonym for the common +-- case where we want to match on the argument/result type, but +-- ignoring the AnonArgFlag +pattern FunTy :: Type -> Type -> Type +pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } + + End of commented out block +---------------------------------- -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat differently: + + (a) Predicate types + Test: isPredTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) Coercion types are primitive, unboxed equalities + Test: isCoVarTy + Binders: CoVars (can appear in coercions) + Kind: TYPE (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) Evidence types is the type of evidence manipulated by + the type constraint solver. + Test: isEvVarType + Binders: EvVars + Kind: Constraint or TYPE (TupleRep []) + Examples: all coercion types and predicate types + +Coercion types and predicate types are mutually exclusive, +but evidence types are a superset of both. + +When treated as a user type, + + - Predicates (of kind Constraint) are invisible and are + implicitly instantiated + + - Coercion types, and non-pred evidence types (i.e. not + of kind Constrain), are just regular old types, are + visible, and are not implicitly instantiated. + +In a FunTy { ft_af = InvisArg }, the argument type is always +a Predicate type. + +Note [Constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do we allow a type constructor to have a kind like + S :: Eq a => a -> Type + +No, we do not. Doing so would mean would need a TyConApp like + S @k @(d :: Eq k) (ty :: k) + and we have no way to build, or decompose, evidence like + (d :: Eq k) at the type level. + +But we admit one exception: equality. We /do/ allow, say, + MkT :: (a ~ b) => a -> b -> Type a b + +Why? Because we can, without much difficulty. Moreover +we can promote a GADT data constructor (see TyCon +Note [Promoted data constructors]), like + data GT a b where + MkGT : a -> a -> GT a a +so programmers might reasonably expect to be able to +promote MkT as well. + +How does this work? + +* In TcValidity.checkConstraintsOK we reject kinds that + have constraints other than (a~b) and (a~~b). + +* In Inst.tcInstInvisibleTyBinder we instantiate a call + of MkT by emitting + [W] co :: alpha ~# beta + and producing the elaborated term + MkT @alpha @beta (Eq# alpha beta co) + We don't generate a boxed "Wanted"; we generate only a + regular old /unboxed/ primitive-equality Wanted, and build + the box on the spot. + +* How can we get such a MkT? By promoting a GADT-style data + constructor + data T a b where + MkT :: (a~b) => a -> b -> T a b + See DataCon.mkPromotedDataCon + and Note [Promoted data constructors] in GHC.Core.TyCon + +* We support both homogeneous (~) and heterogeneous (~~) + equality. (See Note [The equality types story] + in TysPrim for a primer on these equality types.) + +* How do we prevent a MkT having an illegal constraint like + Eq a? We check for this at use-sites; see TcHsType.tcTyVar, + specifically dc_theta_illegal_constraint. + +* Notice that nothing special happens if + K :: (a ~# b) => blah + because (a ~# b) is not a predicate type, and is never + implicitly instantiated. (Mind you, it's not clear how you + could creates a type constructor with such a kind.) See + Note [Types for coercions, predicates, and evidence] + +* The existence of promoted MkT with an equality-constraint + argument is the (only) reason that the AnonTCB constructor + of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + For example, when we promote the data constructor + MkT :: forall a b. (a~b) => a -> b -> T a b + we get a PromotedDataCon with tyConBinders + Bndr (a :: Type) (NamedTCB Inferred) + Bndr (b :: Type) (NamedTCB Inferred) + Bndr (_ :: a ~ b) (AnonTCB InvisArg) + Bndr (_ :: a) (AnonTCB VisArg)) + Bndr (_ :: b) (AnonTCB VisArg)) + +* One might reasonably wonder who *unpacks* these boxes once they are + made. After all, there is no type-level `case` construct. The + surprising answer is that no one ever does. Instead, if a GADT + constructor is used on the left-hand side of a type family equation, + that occurrence forces GHC to unify the types in question. For + example: + + data G a where + MkG :: G Bool + + type family F (x :: G a) :: a where + F MkG = False + + When checking the LHS `F MkG`, GHC sees the MkG constructor and then must + unify F's implicit parameter `a` with Bool. This succeeds, making the equation + + F Bool (MkG @Bool ) = False + + Note that we never need unpack the coercion. This is because type + family equations are *not* parametric in their kind variables. That + is, we could have just said + + type family H (x :: G a) :: a where + H _ = False + + The presence of False on the RHS also forces `a` to become Bool, + giving us + + H Bool _ = False + + The fact that any of this works stems from the lack of phase + separation between types and kinds (unlike the very present phase + separation between terms and types). + + Once we have the ability to pattern-match on types below top-level, + this will no longer cut it, but it seems fine for now. + + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is Int |> <*> the same as Int? YES! In order to reduce headaches, +we decide that any reflexive casts in types are just ignored. +(Indeed they must be. See Note [Respecting definitional equality].) +More generally, the `eqType` function, which defines Core's type equality +relation, ignores casts and coercion arguments, as long as the +two types have the same kind. This allows us to be a little sloppier +in keeping track of coercions, which is a good thing. It also means +that eqType does not depend on eqCoercion, which is also a good thing. + +Why is this sensible? That is, why is something different than α-equivalence +appropriate for the implementation of eqType? + +Anything smaller than ~ and homogeneous is an appropriate definition for +equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any +expression of type τ can be transmuted to one of type σ at any point by +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. + +But let's be more precise. If we examine the typing rules of FC (say, those in +https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) +there are several places where the same metavariable is used in two different +premises to a rule. (For example, see Ty_App.) There is an implicit equality +check here. What definition of equality should we use? By convention, we use +α-equivalence. Take any rule with one (or more) of these implicit equality +checks. Then there is an admissible rule that uses ~ instead of the implicit +check, adding in casts as appropriate. + +The only problem here is that ~ is heterogeneous. To make the kinds work out +in the admissible rule that uses ~, it is necessary to homogenize the +coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; +we use η |> kind η, which is homogeneous. + +The effect of this all is that eqType, the implementation of the implicit +equality check, can use any homogeneous relation that is smaller than ~, as +those rules must also be admissible. + +A more drawn out argument around all of this is presented in Section 7.2 of +Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). + +What would go wrong if we insisted on the casts matching? See the beginning of +Section 8 in the unpublished paper above. Theoretically, nothing at all goes +wrong. But in practical terms, getting the coercions right proved to be +nightmarish. And types would explode: during kind-checking, we often produce +reflexive kind coercions. When we try to cast by these, mkCastTy just discards +them. But if we used an eqType that distinguished between Int and Int |> <*>, +then we couldn't discard -- the output of kind-checking would be enormous, +and we would need enormous casts with lots of CoherenceCo's to straighten +them out. + +Would anything go wrong if eqType respected type families? No, not at all. But +that makes eqType rather hard to implement. + +Thus, the guideline for eqType is that it should be the largest +easy-to-implement relation that is still smaller than ~ and homogeneous. The +precise choice of relation is somewhat incidental, as long as the smart +constructors and destructors in Type respect whatever relation is chosen. + +Another helpful principle with eqType is this: + + (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. + +This principle also tells us that eqType must relate only types with the +same kinds. + +Note [Respecting definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Non-trivial definitional equality] introduces the property (EQ). +How is this upheld? + +Any function that pattern matches on all the constructors will have to +consider the possibility of CastTy. Presumably, those functions will handle +CastTy appropriately and we'll be OK. + +More dangerous are the splitXXX functions. Let's focus on splitTyConApp. +We don't want it to fail on (T a b c |> co). Happily, if we have + (T a b c |> co) `eqType` (T d e f) +then co must be reflexive. Why? eqType checks that the kinds are equal, as +well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). +By the kind check, we know that (T a b c |> co) and (T d e f) have the same +kind. So the only way that co could be non-reflexive is for (T a b c) to have +a different kind than (T d e f). But because T's kind is closed (all tycon kinds +are closed), the only way for this to happen is that one of the arguments has +to differ, leading to a contradiction. Thus, co is reflexive. + +Accordingly, by eliminating reflexive casts, splitTyConApp need not worry +about outermost casts to uphold (EQ). Eliminating reflexive casts is done +in mkCastTy. + +Unforunately, that's not the end of the story. Consider comparing + (T a b c) =? (T a b |> (co -> )) (c |> co) +These two types have the same kind (Type), but the left type is a TyConApp +while the right type is not. To handle this case, we say that the right-hand +type is ill-formed, requiring an AppTy never to have a casted TyConApp +on its left. It is easy enough to pull around the coercions to maintain +this invariant, as done in Type.mkAppTy. In the example above, trying to +form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). +Both the casts there are reflexive and will be dropped. Huzzah. + +This idea of pulling coercions to the right works for splitAppTy as well. + +However, there is one hiccup: it's possible that a coercion doesn't relate two +Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, +then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't +be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not +`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate +our (EQ) property. + +In order to detect reflexive casts reliably, we must make sure not +to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). + +One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. +The kind of the body is the same as the kind of the ForAllTy. Accordingly, + + ForAllTy tv (ty |> co) and (ForAllTy tv ty) |> co + +are `eqType`. But only the first can be split by splitForAllTy. So we forbid +the second form, instead pushing the coercion inside to get the first form. +This is done in mkCastTy. + +In sum, in order to uphold (EQ), we need the following invariants: + + (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable + cast is one that relates either a FunTy to a FunTy or a + ForAllTy to a ForAllTy. + (EQ2) No reflexive casts in CastTy. + (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] + +These invariants are all documented above, in the declaration for Type. + +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~ t2). e + +What type should we give to this expression? + (1) forall (co:t1 ~ t2) -> t + (2) (t1 ~ t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkLamType, we check whether the variable is a coercion +variable (of type (t1 ~# t2), and whether it is un-used in the +body. If so, it returns a FunTy instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is +unnecessary when it is known from the context that the input variable +is a type variable. In those cases, we use mkForAllTy. + +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the (truncated) typing rule for the dependent ForAllTy: + + inner : TYPE r + tyvar is not free in r + ---------------------------------------- + ForAllTy (Bndr tyvar vis) inner : TYPE r + +Note that the kind of `inner` is the kind of the overall ForAllTy. This is +necessary because every ForAllTy over a type variable is erased at runtime. +Thus the runtime representation of a ForAllTy (as encoded, via TYPE rep, in +the kind) must be the same as the representation of the body. We must check +for skolem-escape, though. The skolem-escape would prevent a definition like + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). a + +because the type's kind (TYPE r) mentions the out-of-scope r. Luckily, the real +type of undefined is + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + +and that HasCallStack constraint neatly sidesteps the potential skolem-escape +problem. + +If the bound variable is a coercion variable: + + inner : TYPE r + covar is free in inner + ------------------------------------ + ForAllTy (Bndr covar vis) inner : Type + +Here, the kind of the ForAllTy is just Type, because coercion abstractions +are *not* erased. The "covar is free in inner" premise is solely to maintain +the representation invariant documented in +Note [Unused coercion variable in ForAllTy]. Though there is surface similarity +between this free-var check and the one in the tyvar rule, these two restrictions +are truly unrelated. + +-} + +-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See +-- Note [Type checking recursive type and class declarations] in +-- TcTyClsDecls +type KnotTied ty = ty + +{- ********************************************************************** +* * + TyCoBinder and ArgFlag +* * +********************************************************************** -} + +-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [TyCoBinders] +data TyCoBinder + = Named TyCoVarBinder -- A type-lambda binder + | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. + -- Visibility is determined by the AnonArgFlag + deriving Data.Data + +instance Outputable TyCoBinder where + ppr (Anon af ty) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) + + +-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' +-- in the 'Named' field. +type TyBinder = TyCoBinder + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyCoVarBinder -> VarSet +delBinderVar vars (Bndr tv _) = vars `delVarSet` tv + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyCoBinder -> Bool +isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis +isInvisibleBinder (Anon InvisArg _) = True +isInvisibleBinder (Anon VisArg _) = False + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyCoBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +isNamedBinder :: TyCoBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder (Anon {}) = False + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: TyCoBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +{- Note [TyCoBinders] +~~~~~~~~~~~~~~~~~~~ +A ForAllTy contains a TyCoVarBinder. But a type can be decomposed +to a telescope consisting of a [TyCoBinder] + +A TyCoBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * A non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + + +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. + Each TyCoVarBinder + Bndr a tvis + is equipped with tvis::ArgFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term +| tvis :: ArgFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: T :: forall k -> type Arg required: T * +| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f4 :: a b -> Int + So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f5 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: like Specified, but every binder is written in braces: + f :: forall {k} (a:k). S k a -> Int + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). + +Note [No Required TyCoBinder in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Required foralls for term variables, including pattern +synonyms and data constructors. Why? Because then an application +would need a /compulsory/ type argument (possibly without an "@"?), +thus (f Int); and we don't have concrete syntax for that. + +We could change this decision, but Required, Named TyCoBinders are rare +anyway. (Most are Anons.) + +However the type of a term can (just about) have a required quantifier; +see Note [Required quantifiers in the type of a term] in TcExpr. +-} + + +{- ********************************************************************** +* * + PredType +* * +********************************************************************** -} + + +-- | A type of the form @p@ of constraint kind represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to +-- have this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + +infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } + +mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type +mkVisFunTy = mkFunTy VisArg +mkInvisFunTy = mkFunTy InvisArg + +-- | Make nested arrow types +mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type +mkVisFunTys tys ty = foldr mkVisFunTy ty tys +mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys + +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty + +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +mkPiTy:: TyCoBinder -> Type -> Type +mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } +mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty + +mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. + -- - P, N, and R stand for coercions of the given role + -- - e stands for a coercion of a specific unknown role + -- (think "role polymorphism") + -- - "e" stands for an explicit role parameter indicating role e. + -- - _ stands for a parameter that is not a Role or Coercion. + + -- These ones mirror the shape of types + = -- Refl :: _ -> N + Refl Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) + + -- GRefl :: "e" -> _ -> Maybe N -> e + -- See Note [Generalized reflexive coercion] + | GRefl Role Type MCoercionN -- See Note [Refl invariant] + -- Use (Refl ty), not (GRefl Nominal ty MRefl) + -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + -- TyCon is never a saturated (->); use FunCo instead + + | AppCo Coercion CoercionN -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyCoVar KindCoercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + | FunCo Role Coercion Coercion -- lift FunTy + -- FunCo :: "e" -> e -> e -> e + -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? + -- Because the AnonArgFlag has no impact on Core; it is only + -- there to guide implicit instantiation of Haskell source + -- types, and that is irrelevant for coercions, which are + -- Core-only. + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> ?? -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + -- The roles of the argument coercions are determined + -- by the cab_roles field of the relevant branch of the CoAxiom + + | AxiomRuleCo CoAxiomRule [Coercion] + -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + -- + -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) + -- That is: the role of the entire coercion is redundantly cached here. + -- See Note [NthCo Cached Roles] + + | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion CoercionN + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo CoercionN -- Turns a ~N into a ~R + -- :: N -> R + + | HoleCo CoercionHole -- ^ See Note [Coercion holes] + -- Only present during typechecking + deriving Data.Data + +type CoercionN = Coercion -- always nominal +type CoercionR = Coercion -- always representational +type CoercionP = Coercion -- always phantom +type KindCoercion = CoercionN -- always nominal + +instance Outputable Coercion where + ppr = pprCo + +-- | A semantically more meaningful type to represent what may or may not be a +-- useful 'Coercion'. +data MCoercion + = MRefl + -- A trivial Reflexivity coercion + | MCo Coercion + -- Other coercions + deriving Data.Data +type MCoercionR = MCoercion +type MCoercionN = MCoercion + +instance Outputable MCoercion where + ppr MRefl = text "MRefl" + ppr (MCo co) = text "MCo" <+> ppr co + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: + +Coercions have the following invariant + Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. + +You might think that a consequences is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Generalized reflexive coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GRefl is a generalized reflexive coercion (see #15192). It wraps a kind +coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing +rules for GRefl: + + ty : k1 + ------------------------------------ + GRefl r ty MRefl: ty ~r ty + + ty : k1 co :: k1 ~ k2 + ------------------------------------ + GRefl r ty (MCo co) : ty ~r ty |> co + +Consider we have + + g1 :: s ~r t + s :: k1 + g2 :: k1 ~ k2 + +and we want to construct a coercions co which has type + + (s |> g2) ~r t + +We can define + + co = Sym (GRefl r s g2) ; g1 + +It is easy to see that + + Refl == GRefl Nominal ty MRefl :: ty ~n ty + +A nominal reflexive coercion is quite common, so we keep the special form Refl to +save allocation. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + + kind_co : k1 ~ k2 + tv1:k1 |- co : t1 ~ t2 + ------------------------------------------------------------------- + ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ + all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) + +First, the TyCoVar stored in a ForAllCo is really an optimisation: this field +should be a Name, as its kind is redundant. Thinking of the field as a Name +is helpful in understanding what a ForAllCo means. +The kind of TyCoVar always matches the left-hand kind of the coercion. + +The idea is that kind_co gives the two kinds of the tyvar. See how, in the +conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + +Of course, a type variable can't have different kinds at the same time. So, +we arbitrarily prefer the first kind when using tv1 in the inner coercion +co, which shows that t1 equals t2. + +The last wrinkle is that we need to fix the kinds in the conclusion. In +t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of +the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with +(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it +mentions the same name with different kinds, but it *is* well-kinded, noting +that `(tv1:k2) |> sym kind_co` has kind k1. + +This all really would work storing just a Name in the ForAllCo. But we can't +add Names to, e.g., VarSets, and there generally is just an impedance mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo r 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [NthCo Cached Roles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we cache the role of NthCo in the NthCo constructor? +Because computing role(Nth i co) involves figuring out that + + co :: T tys1 ~ T tys2 + +using coercionKind, and finding (coercionRole co), and then looking +at the tyConRoles of T. Avoiding bad asymptotic behaviour here means +we have to compute the kind and role of a coercion simultaneously, +which makes the code complicated and inefficient. + +This only happens for NthCo. Caching the role solves the problem, and +allows coercionKind and coercionRole to be simple. + +See #11735 + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + + +%************************************************************************ +%* * + UnivCoProvenance +%* * +%************************************************************************ + +A UnivCo is a coercion whose proof does not directly express its role +and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). + +The different kinds of UnivCo are described by UnivCoProvenance. Really +each is entirely separate, but they all share the need to represent their +role and kind, which is done in the UnivCo constructor. + +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. The UnivCoProvenance specifies more exactly what the coercion really +-- is and why a program should (or shouldn't!) trust the coercion. +-- It is reasonable to consider each constructor of 'UnivCoProvenance' +-- as a totally independent coercion form; their only commonality is +-- that they don't tell you what types they coercion between. (That info +-- is in the 'UnivCo' constructor of 'Coercion'. +data UnivCoProvenance + = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions + + | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions + + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + + deriving Data.Data + +instance Outputable UnivCoProvenance where + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { ch_co_var :: CoVar + -- See Note [CoercionHoles and coercion free variables] + + , ch_blocker :: BlockSubstFlag -- should this hole block substitution? + -- See (2a) in TcCanonical + -- Note [Equalities with incompatible kinds] + , ch_ref :: IORef (Maybe Coercion) + } + +data BlockSubstFlag = YesBlockSubst + | NoBlockSubst + +coHoleCoVar :: CoercionHole -> CoVar +coHoleCoVar = ch_co_var + +setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole +setCoHoleCoVar h cv = h { ch_co_var = cv } + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) + +instance Outputable BlockSubstFlag where + ppr YesBlockSubst = text "YesBlockSubst" + ppr NoBlockSubst = text "NoBlockSubst" + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~ +During typechecking, constraint solving for type classes works by + - Generate an evidence Id, d7 :: Num a + - Wrap it in a Wanted constraint, [W] d7 :: Num a + - Use the evidence Id where the evidence is needed + - Solve the constraint later + - When solved, add an enclosing let-binding let d7 = .... in .... + which actually binds d7 to the (Num a) evidence + +For equality constraints we use a different strategy. See Note [The +equality types story] in TysPrim for background on equality constraints. + - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just + like type classes above. (Indeed, boxed equality constraints *are* classes.) + - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) + we use a different plan + +For unboxed equalities: + - Generate a CoercionHole, a mutable variable just like a unification + variable + - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest + - Use the CoercionHole in a Coercion, via HoleCo + - Solve the constraint later + - When solved, fill in the CoercionHole by side effect, instead of + doing the let-binding thing + +The main reason for all this is that there may be no good place to let-bind +the evidence for unboxed equalities: + + - We emit constraints for kind coercions, to be used to cast a + type's kind. These coercions then must be used in types. Because + they might appear in a top-level type, there is no place to bind + these (unlifted) coercions in the usual way. + + - A coercion for (forall a. t1) ~ (forall a. t2) will look like + forall a. (coercion for t1~t2) + But the coercion for (t1~t2) may mention 'a', and we don't have + let-bindings within coercions. We could add them, but coercion + holes are easier. + + - Moreover, nothing is lost from the lack of let-bindings. For + dictionaries want to achieve sharing to avoid recomoputing the + dictionary. But coercions are entirely erased, so there's little + benefit to sharing. Indeed, even if we had a let-binding, we + always inline types and coercions at every use site and drop the + binding. + +Other notes about HoleCo: + + * INVARIANT: CoercionHole and HoleCo are used only during type checking, + and should never appear in Core. Just like unification variables; a Type + can contain a TcTyVar, but only during type checking. If, one day, we + use type-level information to separate out forms that can appear during + type-checking vs forms that can appear in core proper, holes in Core will + be ruled out. + + * See Note [CoercionHoles and coercion free variables] + + * Coercion holes can be compared for equality like other coercions: + by looking at the types coerced. + + +Note [CoercionHoles and coercion free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does a CoercionHole contain a CoVar, as well as reference to +fill in? Because we want to treat that CoVar as a free variable of +the coercion. See #14584, and Note [What prevents a +constraint from floating] in TcSimplify, item (4): + + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + +Here co2 is a CoercionHole. But we /must/ know that it is free in +co1, because that's all that stops it floating outside the +implication. + + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~ Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) + where + co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) + co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] +-} + + +{- ********************************************************************* +* * + foldType and foldCoercion +* * +********************************************************************* -} + +{- Note [foldType] +~~~~~~~~~~~~~~~~~~ +foldType is a bit more powerful than perhaps it looks: + +* You can fold with an accumulating parameter, via + TyCoFolder env (Endo a) + Recall newtype Endo a = Endo (a->a) + +* You can fold monadically with a monad M, via + TyCoFolder env (M a) + provided you have + instance .. => Monoid (M a) + +Note [mapType vs foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define foldType here, but mapType in module Type. Why? + +* foldType is used in GHC.Core.TyCo.FVs for finding free variables. + It's a very simple function that analyses a type, + but does not construct one. + +* mapType constructs new types, and so it needs to call + the "smart constructors", mkAppTy, mkCastTy, and so on. + These are sophisticated functions, and can't be defined + here in GHC.Core.TyCo.Rep. + +Note [Specialising foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inline foldType at every call site (there are not many), so that it +becomes specialised for the particular monoid *and* TyCoFolder at +that site. This is just for efficiency, but walking over types is +done a *lot* in GHC, so worth optimising. + +We were worried that + TyCoFolder env (Endo a) +might not eta-expand. Recall newtype Endo a = Endo (a->a). + +In particular, given + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet + + tcf :: TyCoFolder enf (Endo a) + tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` tv + + +we want to end up with + fvs ty = go emptyVarSet ty emptyVarSet + where + go env (TyVarTy tv) acc = acc `extendVarSet` tv + ..etc.. + +And indeed this happens. + - Selections from 'tcf' are done at compile time + - 'go' is nicely eta-expanded. + +We were also worried about + deep_fvs :: Type -> TyCoVarSet + deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet + + deep_tcf :: TyCoFolder enf (Endo a) + deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = deep_fvs (varType tv) + `unionVarSet` acc + `extendVarSet` tv + +Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf. +But, amazingly, we get good code here too. GHC is careful not to makr +TyCoFolder data constructor for deep_tcf as a loop breaker, so the +record selections still cancel. And eta expansion still happens too. +-} + +data TyCoFolder env a + = TyCoFolder + { tcf_view :: Type -> Maybe Type -- Optional "view" function + -- E.g. expand synonyms + , tcf_tyvar :: env -> TyVar -> a + , tcf_covar :: env -> CoVar -> a + , tcf_hole :: env -> CoercionHole -> a + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep. + + , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env + -- ^ The returned env is used in the extended scope + } + +{-# INLINE foldTyCo #-} -- See Note [Specialising foldType] +foldTyCo :: Monoid a => TyCoFolder env a -> env + -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) +foldTyCo (TyCoFolder { tcf_view = view + , tcf_tyvar = tyvar + , tcf_tycobinder = tycobinder + , tcf_covar = covar + , tcf_hole = cohole }) env + = (go_ty env, go_tys env, go_co env, go_cos env) + where + go_ty env ty | Just ty' <- view ty = go_ty env ty' + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2 + go_ty _ (LitTy {}) = mempty + go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co + go_ty env (CoercionTy co) = go_co env co + go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res + go_ty env (TyConApp _ tys) = go_tys env tys + go_ty env (ForAllTy (Bndr tv vis) inner) + = let !env' = tycobinder env tv vis -- Avoid building a thunk here + in go_ty env (varType tv) `mappend` go_ty env' inner + + -- Explicit recursion becuase using foldr builds a local + -- loop (with env free) and I'm not confident it'll be + -- lambda lifted in the end + go_tys _ [] = mempty + go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts + + go_cos _ [] = mempty + go_cos env (c:cs) = go_co env c `mappend` go_cos env cs + + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + go_co env (TyConAppCo _ _ args) = go_cos env args + go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (FunCo _ c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (AxiomInstCo _ _ args) = go_cos env args + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 + `mappend` go_ty env t2 + go_co env (SymCo co) = go_co env co + go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (AxiomRuleCo _ cos) = go_cos env cos + go_co env (NthCo _ _ co) = go_co env co + go_co env (LRCo _ co) = go_co env co + go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + go_co env (ForAllCo tv kind_co co) + = go_co env kind_co `mappend` go_ty env (varType tv) + `mappend` go_co env' co + where + env' = tycobinder env tv Inferred + + go_prov env (PhantomProv co) = go_co env co + go_prov env (ProofIrrelProv co) = go_co env co + go_prov _ (PluginProv _) = mempty + +{- ********************************************************************* +* * + typeSize, coercionSize +* * +********************************************************************* -} + +-- NB: We put typeSize/coercionSize here because they are mutually +-- recursive, and have the CPR property. If we have mutual +-- recursion across a hi-boot file, we don't get the CPR property +-- and these functions allocate a tremendous amount of rubbish. +-- It's not critical (because typeSize is really only used in +-- debug mode, but I tripped over an example (T5642) in which +-- typeSize was one of the biggest single allocators in all of GHC. +-- And it's easy to fix, so I did. + +-- NB: typeSize does not respect `eqType`, in that two types that +-- are `eqType` may return different sizes. This is OK, because this +-- function is used only in reporting, not decision-making. + +typeSize :: Type -> Int +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (GRefl _ ty MRefl) = typeSize ty +coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co +coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h +coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (CoVarCo _) = 1 +coercionSize (HoleCo _) = 1 +coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) + +provSize :: UnivCoProvenance -> Int +provSize (PhantomProv co) = 1 + coercionSize co +provSize (ProofIrrelProv co) = 1 + coercionSize co +provSize (PluginProv _) = 1 diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -0,0 +1,23 @@ +module GHC.Core.TyCo.Rep where + +import Data.Data ( Data ) +import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) + +data Type +data TyThing +data Coercion +data UnivCoProvenance +data TyLit +data TyCoBinder +data MCoercion + +type PredType = Type +type Kind = Type +type ThetaType = [PredType] +type CoercionN = Coercion +type MCoercionN = MCoercion + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkForAllTy :: Var -> ArgFlag -> Type -> Type + +instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -0,0 +1,1032 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +Type and Coercion - friends' interface +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Substitution into types and coercions. +module GHC.Core.TyCo.Subst + ( + -- * Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, + getTvSubstEnv, + getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, + isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstWithClone, + extendCvSubst, extendCvSubstWithClone, + extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + unionTCvSubst, zipTyEnv, zipCoEnv, + zipTvSubst, zipCvSubst, + zipTCvSubst, + mkTvSubstPrs, + + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyWithInScope, + substTys, substTheta, + lookupTyVar, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, + substTyVar, substTyVars, substTyCoVars, + substForAllCoBndr, + substVarBndrUsing, substForAllCoBndrUsing, + checkValidSubst, isValidTCvSubst, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.Type + ( mkCastTy, mkAppTy, isCoercionTy ) +import {-# SOURCE #-} GHC.Core.Coercion + ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo + , mkNomReflCo, mkSubCo, mkSymCo + , mkFunCo, mkForAllCo, mkUnivCo + , mkAxiomInstCo, mkAppCo, mkGReflCo + , mkInstCo, mkLRCo, mkTyConAppCo + , mkCoercionType + , coercionKind, coercionLKind, coVarKindsTypesRole ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import Pair +import Util +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import Outputable + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion substitution +-- +-- #tcvsubst_invariant# +-- The following invariants must hold of a 'TCvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reach a fixed point. +data TCvSubst + = TCvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + CvSubstEnv -- Substitutes coercion variables + -- See Note [Substitutions apply only once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + -- and Note [The substitution invariant] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- NB: A TvSubstEnv is used + -- both inside a TCvSubst (with the apply-once invariant + -- discussed in Note [Substitutions apply only once], + -- and also independently in the middle of matching, + -- and unification (see Types.Unify). + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- Note [The substitution invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When calling (substTy subst ty) it should be the case that +the in-scope set in the substitution is a superset of both: + + (SIa) The free vars of the range of the substitution + (SIb) The free vars of ty minus the domain of the substitution + +The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) + +* Reason for (SIa). Consider + substTy [a :-> Maybe b] (forall b. b->a) + we must rename the forall b, to get + forall b2. b2 -> Maybe b + Making 'b' part of the in-scope set forces this renaming to + take place. + +* Reason for (SIb). Consider + substTy [a :-> Maybe b] (forall b. (a,b,x)) + Then if we use the in-scope set {b}, satisfying (SIa), there is + a danger we will rename the forall'd variable to 'x' by mistake, + getting this: + forall x. (Maybe b, x, x) + Breaking (SIb) caused the bug from #11371. + +Note: if the free vars of the range of the substitution are freshly created, +then the problems of (SIa) can't happen, and so it would be sound to +ignore (SIa). + +Note [Substitutions apply only once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + ******************************************************** + *** So a substitution must be applied precisely once *** + ******************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tcvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +However, the constructor used to create type variables is distinct from +that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note +that it would be possible to use the CoercionTy constructor to combine +these environments, but that seems like a false economy. + +Note that the TvSubstEnv should *never* map a CoVar (built with the Id +constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, +the range of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +composeTCvSubstEnv :: InScopeSet + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) + = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TCvSubst in_scope tenv1 cenv1 + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. +composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) + = TCvSubst is3 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + +emptyTCvSubst :: TCvSubst +emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + +mkEmptyTCvSubst :: InScopeSet -> TCvSubst +mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv + +isEmptyTCvSubst :: TCvSubst -> Bool + -- See Note [Extending the TvSubstEnv] +isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst +mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst +mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv + +mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +-- | Returns the free variables of the types in the range of a substitution as +-- a non-deterministic set. +getTCvSubstRangeFVs :: TCvSubst -> VarSet +getTCvSubstRangeFVs (TCvSubst _ tenv cenv) + = unionVarSet tenvFVs cenvFVs + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +isInScope :: Var -> TCvSubst -> Bool +isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope + +notElemTCvSubst :: Var -> TCvSubst -> Bool +notElemTCvSubst v (TCvSubst _ tenv cenv) + | isTyVar v + = not (v `elemVarEnv` tenv) + | otherwise + = not (v `elemVarEnv` cenv) + +setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst +setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + +setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst +setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv + +zapTCvSubst :: TCvSubst -> TCvSubst +zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv + +extendTCvInScope :: TCvSubst -> Var -> TCvSubst +extendTCvInScope (TCvSubst in_scope tenv cenv) var + = TCvSubst (extendInScopeSet in_scope var) tenv cenv + +extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst +extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv + +extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst +extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv + +extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst subst v ty + | isTyVar v + = extendTvSubst subst v ty + | CoercionTy co <- ty + = extendCvSubst subst v co + | otherwise + = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) + +extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + +extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv + +extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty + = ASSERT( isTyVar v ) + extendTvSubstAndInScope subst v ty +extendTvSubstBinderAndInScope subst (Anon {}) _ + = subst + +extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set +extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv + where + new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' + +extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst +extendCvSubst (TCvSubst in_scope tenv cenv) v co + = TCvSubst in_scope tenv (extendVarEnv cenv v co) + +extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst +extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + tenv + (extendVarEnv cenv cv (mkCoVarCo cv')) + where + new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' + +extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + +extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTvSubstList subst tvs tys + = foldl2 extendTvSubst subst tvs tys + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +-- Works when the ranges are disjoint +unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) + && not (cenv1 `intersectsVarEnv` cenv2) ) + TCvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- mkTvSubstPrs and zipTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No CoVars, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst +zipTvSubst tvs tys + = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv + where + tenv = zipTyEnv tvs tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No TyVars, please! +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst cvs cos + = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where + cenv = zipCoEnv cvs cos + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst tcvs tys + = zip_tcvsubst tcvs tys $ + mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the +-- incoming environment. No CoVars, please! +mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst +mkTvSubstPrs prs = + ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) + mkTvSubst in_scope tenv + where tenv = mkVarEnv prs + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs + onlyTyVarsAndNoCoercionTy = + and [ isTyVar tv && not (isCoercionTy ty) + | (tv, ty) <- prs ] + +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars) + = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) + | otherwise + = ASSERT( all (not . isCoercionTy) tys ) + mkVarEnv (zipEqual "zipTyEnv" tyvars tys) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ text "TCvSubst", + nest 2 (text "In scope:" <+> ppr ins), + nest 2 (text "Type env:" <+> ppr tenv), + nest 2 (text "Co env:" <+> ppr cenv) ] + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Here is the typing rule: + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +Note [Substituting in a coercion hole] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It seems highly suspicious to be substituting in a coercion that still +has coercion holes. Yet, this can happen in a situation like this: + + f :: forall k. k :~: Type -> () + f Refl = let x :: forall (a :: k). [a] -> ... + x = ... + +When we check x's type signature, we require that k ~ Type. We indeed +know this due to the Refl pattern match, but the eager unifier can't +make use of givens. So, when we're done looking at x's type, a coercion +hole will remain. Then, when we're checking x's definition, we skolemise +x's type (in order to, e.g., bring the scoped type variable `a` into scope). +This requires performing a substitution for the fresh skolem variables. + +This substitution needs to affect the kind of the coercion hole, too -- +otherwise, the kind will have an out-of-scope variable in it. More problematically +in practice (we won't actually notice the out-of-scope variable ever), skolems +in the kind might have too high a level, triggering a failure to uphold the +invariant that no free variables in a type have a higher level than the +ambient level in the type checker. In the event of having free variables in the +hole's kind, I'm pretty sure we'll always have an erroneous program, so we +don't need to worry what will happen when the hole gets filled in. After all, +a hole relating a locally-bound type variable will be unable to be solved. This +is why it's OK not to look through the IORef of a coercion hole during +substitution. + +-} + +-- | Type substitution, see 'zipTvSubst' +substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type +-- Works only if the domain of the substitution is a +-- superset of the type being substituted into +substTyWith tvs tys = {-#SCC "substTyWith" #-} + ASSERT( tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type +substTyWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substTyUnchecked (zipTvSubst tvs tys) + +-- | Substitute tyvars within a type using a known 'InScopeSet'. +-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution +-- invariant]; specifically it should include the free vars of 'tys', +-- and of 'ty' minus the domain of the subst. +substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope in_scope tvs tys ty = + ASSERT( tvs `equalLength` tys ) + substTy (mkTvSubst in_scope tenv) ty + where tenv = zipTyEnv tvs tys + +-- | Coercion substitution, see 'zipTvSubst' +substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) + +-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substCoUnchecked (zipTvSubst tvs tys) + + + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) + +-- | Type substitution, see 'zipTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) + +-- | Substitute within a 'Type' after adding the free variables of the type +-- to the in-scope set. This is useful for the case when the free variables +-- aren't already in the in-scope set or easily available. +-- See also Note [The substitution invariant]. +substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope subst ty = + substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + +-- | When calling `substTy` it should be the case that the in-scope set in +-- the substitution is a superset of the free vars of the range of the +-- substitution. +-- See also Note [The substitution invariant]. +isValidTCvSubst :: TCvSubst -> Bool +isValidTCvSubst (TCvSubst in_scope tenv cenv) = + (tenvFVs `varSetInScope` in_scope) && + (cenvFVs `varSetInScope` in_scope) + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +-- | This checks if the substitution satisfies the invariant from +-- Note [The substitution invariant]. +checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a + = ASSERT2( isValidTCvSubst subst, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$ + text "cenv" <+> ppr cenv $$ + text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos ) + ASSERT2( tysCosFVsInScope, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "cenv" <+> ppr cenv $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos $$ + text "needInScope" <+> ppr needInScope ) + a + where + substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv + -- It's OK to use nonDetKeysUFM here, because we only use this list to + -- remove some elements from a set + needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet` + shallowTyCoVarsOfCos cos) + `delListFromUniqSet_Directly` substDomain + tysCosFVsInScope = needInScope `varSetInScope` in_scope + + +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTy :: HasCallStack => TCvSubst -> Type -> Type +substTy subst ty + | isEmptyTCvSubst subst = ty + | otherwise = checkValidSubst subst [ty] [] $ + subst_ty subst ty + +-- | Substitute within a 'Type' disabling the sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] +substTys subst tys + | isEmptyTCvSubst subst = tys + | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys + +-- | Substitute within several 'Type's disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTysUnchecked to +-- substTys and remove this function. Please don't use in new code. +substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +-- | Substitute within a 'ThetaType' disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to +-- substTheta and remove this function. Please don't use in new code. +substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked = substTysUnchecked + + +subst_ty :: TCvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + go ty@(FunTy { ft_arg = arg, ft_res = res }) + = let !arg' = go arg + !res' = go res + in ty { ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of + (subst', tv') -> + (ForAllTy $! ((Bndr $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: TCvSubst -> TyVar -> Type +substTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion +substCo subst co + | isEmptyTCvSubst subst = co + | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + +-- | Substitute within a 'Coercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos + | isEmptyTCvSubst subst = cos + | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go_mco :: MCoercion -> MCoercion + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go :: Coercion -> Coercion + go (Refl ty) = mkNomReflCo $! (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) + go (TyConAppCo r tc args)= let args' = map go args + in args' `seqList` mkTyConAppCo r tc args' + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv kind_co co) + = case substForAllCoBndrUnchecked subst tv kind_co of + (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co + go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos + go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (NthCo r d co) = mkNthCo r d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (AxiomRuleCo c cs) = let cs1 = map go cs + in cs1 `seqList` AxiomRuleCo c cs1 + go (HoleCo h) = HoleCo $! go_hole h + + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) + = h { ch_co_var = updateVarType go_ty cv } + +substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrUsing False (substCo subst) subst + +-- | Like 'substForAllCoBndr', but disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked subst + = substForAllCoBndrUsing False (substCoUnchecked subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sym sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var + +substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> KindCoercion + -> (TCvSubst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + = ASSERT( isTyVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change && not sym = delVarEnv tenv old_var + | sym = extendVarEnv tenv old_var $ + TyVarTy new_var `CastTy` new_kind_co + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + new_ki1 = coercionLKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> CoVar -> KindCoercion + -> (TCvSubst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ASSERT( isCoVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change && not sym = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair h1 h2 = coercionKind new_kind_co + + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type + new_var_type | sym = h2 + | otherwise = h1 + +substCoVar :: TCvSubst -> CoVar -> Coercion +substCoVar (TCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrUsing substTy + +substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs = mapAccumL substTyVarBndr + +substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (TCvSubst -> Type -> Type) + -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsing + :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) + ASSERT( isTyVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubst] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + -- The uniqAway part makes sure the new variable is not already in scope + +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + new_co = mkCoVarCo new_var + no_kind_change = noFreeVarsOfTypes [t1, t2] + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 + new_var_type = mkCoercionType role t1' t2' + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) +cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq + = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars + (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + where + old_ki = tyVarKind tv + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + + tv1 | no_kind_change = tv + | otherwise = setTyVarKind tv (substTy subst old_ki) + + tv' = setVarUnique tv1 uniq + +cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Tidying types and coercions for printing in error messages. +module GHC.Core.TyCo.Tidy + ( + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos, + tidyTyCoVarBinder, tidyTyCoVarBinders + ) where + +import GhcPrelude + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) + +import GHC.Types.Name hiding (varName) +import GHC.Types.Var +import GHC.Types.Var.Env +import Util (seqList) + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs + +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (occ_env', occ') -> ((occ_env', subst'), var') + where + subst' = extendVarEnv subst var var' + var' = setVarType (setVarName var name') type' + type' = tidyType tidy_env (varType var) + name' = tidyNameOcc name occ' + name = varName var + +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Note [Tidying multiple names at once] in GHC.Types.Names.OccName +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + +getHelpfulOccName :: TyCoVar -> OccName +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOcc (occNameString occ ++ "0") + | otherwise + = occ + where + name = varName tv + occ = getOccName name + +tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyTyCoVarBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) + where + (tidy_env', tv') = tidyVarBndr tidy_env tv + +tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyTyCoVarBinders tidy_env tvbs + = mapAccumL tidyTyCoVarBinder + (avoidNameClashes (binderVars tvbs) tidy_env) tvbs + +--------------- +tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars tidy_env tyvars + = fst (tidyOpenTyCoVars tidy_env tyvars) + +--------------- +tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars + +--------------- +tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> + let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) + in tidyVarBndr env' tyvar -- Treat it as a binder + +--------------- +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> updateVarType (tidyType env) tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_arg = arg', ft_res = res' } +tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty + where + (tvs, vis, body_ty) = splitForAllTys' ty + (env', tvs') = tidyVarBndrs env tvs +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + + +-- The following two functions differ from mkForAllTys and splitForAllTys in that +-- they expect/preserve the ArgFlag argument. These belong to types/Type.hs, but +-- how should they be named? +mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs + where + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty + +splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTys' ty = go ty [] [] + where + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) + + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys + = (env', tidyTypes (trimmed_occ_env, var_env) tys) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ + tyCoVarsOfTypesWellScoped tys + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the types, so that we don't gratuitously rename + -- the _bound_ variables of the types. + +--------------- +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in + (env', ty') + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType + +---------------- +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go (Refl ty) = Refl (tidyType env ty) + go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) + where (envp, tvp) = tidyVarBndr env tv + -- the case above duplicates a bit of work in tidying h and the kind + -- of tv. But the alternative is to use coercionKind, which seems worse. + go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (HoleCo h) = HoleCo h + go (AxiomInstCo con ind cos) = let args = map go cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + tidyType env t1) $! tidyType env t2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo r d co) = NthCo r d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos + in cos1 `seqList` AxiomRuleCo ax cos1 + + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCon.hs @@ -0,0 +1,2813 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @TyCon@ datatype +-} + +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Core.TyCon( + -- * Main TyCon data types + TyCon, + AlgTyConRhs(..), visibleDataCons, + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Injectivity(..), + RuntimeRepInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), TyConTyCoBinder, + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, + tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + noTcTyConScopedTyVars, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isTypeSynonymTyCon, + mustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isKindTyCon, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, + + isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, + isDataSumTyCon_maybe, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isUnliftedTyCon, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + isTcLevPoly, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, famTcResVar, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConRuntimeRepInfo, + tyConBinders, tyConResKind, tyConTyVarBinders, + tcTyConScopedTyVars, tcTyConIsPoly, + mkTyConTagMap, + + -- ** Manipulating TyCons + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + isVoidRep, isGcPtrRep, + primRepSizeB, + primElemRepSizeB, + primRepIsFloat, + primRepsCompatible, + primRepCompatible, + + -- * Recursion breaking + RecTcChecker, initRecTc, defaultRecTcMaxBound, + setRecTcMaxBound, checkRecTc + +) where + +#include "HsVersions.h" + +import GhcPrelude +import GHC.Platform + +import {-# SOURCE #-} GHC.Core.TyCo.Rep + ( Kind, Type, PredType, mkForAllTy, mkFunTy ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr + ( pprType ) +import {-# SOURCE #-} TysWiredIn + ( runtimeRepTyCon, constraintKind + , vecCountTyCon, vecElemTyCon, liftedTypeKind ) +import {-# SOURCE #-} GHC.Core.DataCon + ( DataCon, dataConExTyCoVars, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumCon ) + +import Binary +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Class +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Core.Coercion.Axiom +import PrelNames +import Maybes +import Outputable +import FastStringEnv +import GHC.Types.FieldLabel +import Constants +import Util +import GHC.Types.Unique( tyConRepNameUnique, dataConTyRepNameUnique ) +import GHC.Types.Unique.Set +import GHC.Types.Module + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as he did with type + synonym families. He just sees constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in GHC.Core.FamInstEnv + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in GHC.Core.FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is only used for overlap checking + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: * + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in TcDeriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no levity polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) + + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in GHC.Hs.Decls + * [Renaming injectivity annotation] in GHC.Rename.Source + * [Verifying injectivity annotation] in GHC.Core.FamInstEnv + * [Type inference for type families with injectivity] in TcInteract + +************************************************************************ +* * + TyConBinder, TyConTyCoBinder +* * +************************************************************************ +-} + +type TyConBinder = VarBndr TyVar TyConBndrVis + +-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really +-- contain CoVar. +type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis + +data TyConBndrVis + = NamedTCB ArgFlag + | AnonTCB AnonArgFlag + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag + ppr (AnonTCB af) = text "AnonTCB" <> ppr af + +mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder +mkAnonTyConBinder af tv = ASSERT( isTyVar tv) + Bndr tv (AnonTCB af) + +mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] +mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs + +mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder +-- The odd argument order supports currying +mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) + Bndr tv (NamedTCB vis) + +mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder VisArg tv + +tyConBinderArgFlag :: TyConBinder -> ArgFlag +tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis + +tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag +tyConBndrVisArgFlag (NamedTCB vis) = vis +tyConBndrVisArgFlag (AnonTCB VisArg) = Required +tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] + +isNamedTyConBinder :: TyConBinder -> Bool +-- Identifies kind variables +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis +isVisibleTcbVis (AnonTCB VisArg) = True +isVisibleTcbVis (AnonTCB InvisArg) = False + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +-- Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k + +tyConTyVarBinders :: [TyConBinder] -- From the TyCon + -> [TyVarBinder] -- Suitable for the foralls of a term function +-- See Note [Building TyVarBinders from TyConBinders] +tyConTyVarBinders tc_bndrs + = map mk_binder tc_bndrs + where + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv + where + vis = case tc_vis of + AnonTCB VisArg -> Specified + AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] + NamedTCB Required -> Specified + NamedTCB vis -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ tv | Bndr tv vis <- tyConBinders tc + , isVisibleTcbVis vis ] + +{- Note [AnonTCB InvisArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's pretty rare to have an (AnonTCB InvisArg) binder. The +only way it can occur is through equality constraints in kinds. These +can arise in one of two ways: + +* In a PromotedDataCon whose kind has an equality constraint: + + 'MkT :: forall a b. (a~b) => blah + + See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and + Note [Promoted data constructors] in this module. +* In a data type whose kind has an equality constraint, as in the + following example from #12102: + + data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type + +When mapping an (AnonTCB InvisArg) to an ArgFlag, in +tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot +specify this arguments, even with visible type/kind application; +instead the type checker must fill it in. + +We map (AnonTCB VisArg) to Required, of course: the user must +provide it. It would be utterly wrong to do this for constraint +arguments, which is why AnonTCB must have the AnonArgFlag in +the first place. + +Note [Building TyVarBinders from TyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +TyConBinders but TyVarBinders (used in forall-type) E.g: + + * From data T a = MkT (Maybe a) + we are going to make a data constructor with type + MkT :: forall a. Maybe a -> T a + See the TyCoVarBinders passed to buildDataCon + + * From class C a where { op :: a -> Maybe a } + we are going to make a default method + $dmop :: forall a. C a => a -> Maybe a + See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType + +Both of these are user-callable. (NB: default methods are not callable +directly by the user but rather via the code generated by 'deriving', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +information right; and that info is in the TyConBinders. +Here is an example: + + data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] + +The TyConBinders for App line up with App's kind, given above. + +But the DataCon MkApp has the type + MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b + +That is, its TyCoVarBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - but changing Anon/Required to Specified + +The last part about Required->Specified comes from this: + data T k (a:k) b = MkT (a b) +Here k is Required in T's kind, but we don't have Required binders in +the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] +in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders +-} + + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder/TyConTyCoBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type/coercion variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) + , Bndr (a:k->*) AnonTCB + , Bndr (b:k) AnonTCB ] + + Note that that are three binders here, including the + kind variable k. + +* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep + for what the visibility flag means. + +* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a + we have + tyConBinders = [ Bndr (a:*) AnonTCB ] + synTcRhs = a -> a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->*) -> k -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by etaExpandAlgTyCon +-} + +instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where + ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) + where + ppr_bi (AnonTCB VisArg) = text "anon-vis" + ppr_bi (AnonTCB InvisArg) = text "anon-invis" + ppr_bi (NamedTCB Required) = text "req" + ppr_bi (NamedTCB Specified) = text "spec" + ppr_bi (NamedTCB Inferred) = text "inf" + +instance Binary TyConBndrVis where + put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { af <- get bh; return (AnonTCB af) } + _ -> do { vis <- get bh; return (NamedTCB vis) } } + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data TyCon + = -- | The function type constructor, @(->)@ + FunTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRepName :: TyConRepName + } + + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- All these constructors are lifted and boxed except unboxed tuples + -- which should have an 'UnboxedAlgTyCon' parent. + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + | AlgTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars scope over: synTcRhs + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see TcValidity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may + -- not contain bottom) but other are lifted, + -- e.g. @RealWorld@ + -- Only relevant if tyConKind = * + + primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons + -- i.e, *, #, ? + } + + -- | Represents promoted data constructor. + | PromotedDataCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConTyCoBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars + dataCon :: DataCon, -- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' + } + + -- | These exist only during type-checking. See Note [How TcTyCons work] + -- in TcTyClsDecls + | TcTyCon { + tyConUnique :: Unique, + tyConName :: Name, + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- NB: the TyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tcTyConScopedTyVars :: [(Name,TyVar)], + -- ^ Scoped tyvars over the tycon's body + -- See Note [Scoped tyvars in a TcTyCon] + + tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? + + tcTyConFlavour :: TyConFlavour + -- ^ What sort of 'TyCon' this represents. + } +{- Note [Scoped tyvars in a TcTyCon] + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyvars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * tyConArity = length required_tvs + +See also Note [How TcTyCons work] in TcTyClsDecls +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched, + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + nt_lev_poly :: Bool + -- 'True' if the newtype can be levity polymorphic when + -- fully applied to its arguments, 'False' otherwise. + -- This can only ever be 'True' with UnliftedNewtypes. + -- + -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt) + -- + -- This is cached to make it cheaper to check if a + -- variable binding is levity polymorphic, as used by + -- isTcLevPoly. + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons + -- See Note [Enumeration types] in GHC.Core.TyCon + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +-- See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType +data RuntimeRepInfo + = NoRRI -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ A constructor of @RuntimeRep@. The argument to the function should + -- be the list of arguments to the promoted datacon. + | VecCount Int -- ^ A constructor of @VecCount@ + | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- that visibility in this sense does not correspond to visibility in +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs + +-- ^ Both type classes as well as family instances imply implicit +-- type constructors. These implicit type constructors refer to their parent +-- structure (ie, the class or family from which they derive) using a type of +-- the following form. +data AlgTyConFlav + = -- | An ordinary type constructor has no parent. + VanillaAlgTyCon + TyConRepName -- For Typeable + + -- | An unboxed type constructor. The TyConRepName is a Maybe since we + -- currently don't allow unboxed sums to be Typeable since there are too + -- many of them. See #13276. + | UnboxedAlgTyCon + (Maybe TyConRepName) + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see FamInstEnv + -- Note [Eta reduction for data families] + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedAlgTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in GHC.Core.TyCon. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, + say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. + +In the case that the right hand side is a type application +ending with the same type variables as the left hand side, we +"eta-contract" the coercion. So if we had + + newtype S a = MkT [a] + +then we would generate the arity 0 axiom CoS : S ~ []. The +primary reason we do this is to make newtype deriving cleaner. + +In the paper we'd write + axiom CoT : (forall t. T t) ~ (forall t. [t]) +and then when we used CoT at a particular type, s, we'd say + CoT @ s +which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal (to Core)? + Monad Parser + Monad IO +which we need to make the derived instance for Monad Parser. + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to ([], Froogle), so that even unsaturated applications +of Parser will work right. This eta reduction is done when the type +constructor is built, and cached in NewTyCon. + +Here's an example that I think showed up in practice +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we get: + w2 = w1 `cast` Foo CoT +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + +This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs. + + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name + -- The Name of the top-level declaration for the Typeable world + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) + = mb_rep_nm +tyConRepName_maybe (AlgTyCon { algTcParent = parent }) + | VanillaAlgTyCon rep_nm <- parent = Just rep_nm + | ClassTyCon _ rep_nm <- parent = Just rep_nm + | UnboxedAlgTyCon rep_nm <- parent = rep_nm +tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm +tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm +tyConRepName_maybe _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] + +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width (cmm/CmmType) is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. + +-} + +-- | A 'PrimRep' is an abstraction of a type. It contains information that +-- the code generator needs in order to pass arguments, return results, +-- and store values of this type. See also Note [RuntimeRep and PrimRep] in +-- GHC.Types.RepType and Note [VoidRep] in GHC.Types.RepType. +data PrimRep + = VoidRep + | LiftedRep + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | Int32Rep -- ^ Signed, 32-bit value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | IntRep -- ^ Signed, word-sized value + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word32Rep -- ^ Unsigned, 32 bit value + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | WordRep -- ^ Unsigned, word-sized value + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = True +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 :: Platform -> PrimRep -> PrimRep -> Bool +primRepCompatible platform rep1 rep2 = + (isUnboxed rep1 == isUnboxed 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 :: Platform -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible platform reps1 reps2 = + length reps1 == length reps2 && + and (zipWith (primRepCompatible platform) reps1 reps2) + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- 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 :: 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 +primElemRepSizeB Int16ElemRep = 2 +primElemRepSizeB Int32ElemRep = 4 +primElemRepSizeB Int64ElemRep = 8 +primElemRepSizeB Word8ElemRep = 1 +primElemRepSizeB Word16ElemRep = 2 +primElemRepSizeB Word32ElemRep = 4 +primElemRepSizeB Word64ElemRep = 8 +primElemRepSizeB FloatElemRep = 4 +primElemRepSizeB DoubleElemRep = 8 + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv tc + | isAlgTyCon tc = algTcFields tc + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +-- | Given the name of the function type constructor and it's kind, create the +-- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want +-- this functionality +mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon +mkFunTyCon name binders rep_nm + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConResKind = liftedTypeKind, + tyConKind = mkTyConKind binders liftedTypeKind, + tyConArity = length binders, + tcRepName = rep_nm + } + +-- | This is the making of an algebraic 'TyCon'. Notably, you have to +-- pass in the generic (in the -XGenerics sense) information about the +-- type constructor - you can get hold of it easily (see Generics +-- module) +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcFields = fieldsOfAlgTcRhs rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcGadtSyntax = gadt_syn + } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> Arity -- ^ Arity of the tuple 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind arity con sort parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = binderVars binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = TupleTyCon { data_con = con, + tup_sort = sort }, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> Arity -- ^ Arity of the sum + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind arity tyvars cons parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = tyvars, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = mkSumTyConRhs cons, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- right-hand side. It lives only during the type-checking of a +-- mutually-recursive group of tycons; it is then zonked to a proper +-- TyCon in zonkTcTyCon. +-- See also Note [Kind checking recursive type and class declarations] +-- in TcTyClsDecls. +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only + -> [(Name,TcTyVar)] -- ^ Scoped type variables; + -- see Note [How TcTyCons work] in TcTyClsDecls + -> Bool -- ^ Is this TcTyCon generalised already? + -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConTyVars = binderVars binders + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tcTyConScopedTyVars = scoped_tvs + , tcTyConIsPoly = poly + , tcTyConFlavour = flav } + +-- | No scoped type variables (to be used with mkTcTyCon). +noTcTyConScopedTyVars :: [(Name, TcTyVar)] +noTcTyConScopedTyVars = [] + +-- | Create an unlifted primitive 'TyCon', such as @Int#@. +mkPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -> [Role] -> TyCon +mkPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) + +-- | Kind constructors +mkKindTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> Name -> TyCon +mkKindTyCon name binders res_kind roles rep_nm + = tc + where + tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + +-- | Create a lifted primitive 'TyCon' such as @RealWorld@ +mkLiftedPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> TyCon +mkLiftedPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + where rep_nm = mkPrelTyConRepName name + +mkPrimTyCon' :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -- (If you need a levity-polymorphic PrimTyCon, change + -- isTcLevPoly.) + -> [Role] + -> Bool -> Maybe TyConRepName -> TyCon +mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length roles, + tcRoles = roles, + isUnlifted = is_unlifted, + primRepName = rep_nm + } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type -> Bool -> Bool -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + = SynonymTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + synTcRhs = rhs, + synIsTau = is_tau, + synIsFamFree = is_fam_free + } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConTyVars = binderVars binders + , famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj + } + + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConTyCoBinder] -> Kind -> [Role] + -> RuntimeRepInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = PromotedDataCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConArity = length roles, + tcRoles = roles, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + dataCon = con, + tcRepName = rep_name, + promDcRepInfo = rep_info + } + +isFunTyCon :: TyCon -> Bool +isFunTyCon (FunTyCon {}) = True +isFunTyCon _ = False + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True +isAbstractTyCon _ = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (PrimTyCon {}) = True +isPrimTyCon _ = False + +-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can +-- only be true for primitive and unboxed-tuple 'TyCon's +isUnliftedTyCon :: TyCon -> Bool +isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) + = is_unlifted +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | SumTyCon {} <- rhs + = True +isUnliftedTyCon _ = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (AlgTyCon {}) = True +isAlgTyCon _ = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True +isVanillaAlgTyCon _ = False + +isDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be true for all @data@ types and false +-- for @newtype@s, unboxed tuples, unboxed sums and type family +-- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isDataTyCon (AlgTyCon {algTcRhs = rhs}) + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon _ = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) +-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) +-- See also Note [Decomposing equality] in TcCanonical +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon _ Phantom = False +isInjectiveTyCon (FunTyCon {}) _ = True +isInjectiveTyCon (AlgTyCon {}) Nominal = True +isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational + = isGenInjAlgRhs rhs +isInjectiveTyCon (SynonymTyCon {}) _ = False +isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True +isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj +isInjectiveTyCon (FamilyTyCon {}) _ = False +isInjectiveTyCon (PrimTyCon {}) _ = True +isInjectiveTyCon (PromotedDataCon {}) _ = True +isInjectiveTyCon (TcTyCon {}) _ = True + -- Reply True for TcTyCon to minimise knock on type errors + -- See Note [How TcTyCons work] item (1) in TcTyClsDecls + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T tys ~X t), then (t's head ~X T). +-- See also Note [Decomposing equality] in TcCanonical +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True +isGenerativeTyCon (FamilyTyCon {}) _ = False + -- in all other cases, injectivity implies generativity +isGenerativeTyCon tc r = isInjectiveTyCon tc r + +-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective +-- with respect to representational equality? +isGenInjAlgRhs :: AlgTyConRhs -> Bool +isGenInjAlgRhs (TupleTyCon {}) = True +isGenInjAlgRhs (SumTyCon {}) = True +isGenInjAlgRhs (DataTyCon {}) = True +isGenInjAlgRhs (AbstractTyCon {}) = False +isGenInjAlgRhs (NewTyCon {}) = False + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon _ = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) +unwrapNewTyCon_maybe _ = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, + nt_etad_rhs = (tvs,rhs) }}) + = Just (tvs, rhs, co) +unwrapNewTyConEtad_maybe _ = Nothing + +isProductTyCon :: TyCon -> Bool +-- True of datatypes or newtypes that have +-- one, non-existential, data constructor +-- See Note [Product types] +isProductTyCon tc@(AlgTyCon {}) + = case algTcRhs tc of + TupleTyCon {} -> True + DataTyCon{ data_cons = [data_con] } + -> null (dataConExTyCoVars data_con) + NewTyCon {} -> True + _ -> False +isProductTyCon _ = False + +isDataProductTyCon_maybe :: TyCon -> Maybe DataCon +-- True of datatypes (not newtypes) with +-- one, vanilla, data constructor +-- See Note [Product types] +isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [con] } + | null (dataConExTyCoVars con) -- non-existential + -> Just con + TupleTyCon { data_con = con } + -> Just con + _ -> Nothing +isDataProductTyCon_maybe _ = Nothing + +isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] +isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = cons } + | cons `lengthExceeds` 1 + , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + SumTyCon { data_cons = cons } + | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + _ -> Nothing +isDataSumTyCon_maybe _ = Nothing + +{- Note [Product types] +~~~~~~~~~~~~~~~~~~~~~~~ +A product type is + * A data type (not a newtype) + * With one, boxed data constructor + * That binds no existential type variables + +The main point is that product types are amenable to unboxing for + * Strict function calls; we can transform + f (D a b) = e + to + fw a b = e + via the worker/wrapper transformation. (Question: couldn't this + work for existentials too?) + + * CPR for function results; we can transform + f x y = let ... in D a b + to + fw x y = let ... in (# a, b #) + +Note that the data constructor /can/ have evidence arguments: equality +constraints, type classes etc. So it can be GADT. These evidence +arguments are simply value arguments, and should not get in the way. +-} + + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (SynonymTyCon {}) = True +isTypeSynonymTyCon _ = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau +isTauTyCon _ = True + +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free +isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isFamFreeTyCon _ = True + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- It'd be unusual to call mustBeSaturated on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +mustBeSaturated :: TyCon -> Bool +mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon _ = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in GHC.Core.TyCon +isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon {} -> arity == 0 + _ -> False +isEnumerationTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) + | OpenSynFamilyTyCon <- flav = True + | DataFamilyTyCon {} <- flav = True +isOpenFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) +isTypeFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isDataFamilyTyCon _ = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenTypeFamilyTyCon _ = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe + (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb +isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc + | FamilyTyCon { famTcInj = inj } <- tc + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe + (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops +isBuiltInSynFamTyCon_maybe _ = Nothing + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +tyConAssoc_maybe :: TyCon -> Maybe TyCon +tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon +tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True +isTupleTyCon _ = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort} <- rhs = Just sort +tyConTuple_maybe _ = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnboxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) +isBoxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) + | SumTyCon {} <- rhs + = True +isUnboxedSumTyCon _ = False + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc +isPromotedDataCon_maybe _ = Nothing + +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqSet Unique +kindTyConKeys = unionManyUniqSets + ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + , vecCountTyCon, vecElemTyCon ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tuples are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (FunTyCon {}) = True +isImplicitTyCon (PrimTyCon {}) = True +isImplicitTyCon (PromotedDataCon {}) = True +isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False +isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent +isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon (TcTyCon {}) = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TcTyCon {}) = True +isTcTyCon _ = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Invariant] in TcHsType +setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } +setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) + +-- | Could this TyCon ever be levity-polymorphic when fully applied? +-- True is safe. False means we're sure. Does only a quick check +-- based on the TyCon's category. +-- Precondition: The fully-applied TyCon has kind (TYPE blah) +isTcLevPoly :: TyCon -> Bool +isTcLevPoly FunTyCon{} = False +isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | UnboxedAlgTyCon _ <- parent + = True + | NewTyCon { nt_lev_poly = lev_poly } <- rhs + = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360) + | otherwise + = False +isTcLevPoly SynonymTyCon{} = True +isTcLevPoly FamilyTyCon{} = True +isTcLevPoly PrimTyCon{} = False +isTcLevPoly TcTyCon{} = False +isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application + +-- ^ Expand a type synonym application, if any +expandSynTyCon_maybe tc tys + | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc + = case tys `listLengthCmp` arity of + GT -> Just (tvs `zip` tys, rhs, drop arity tys) + EQ -> Just (tvs `zip` tys, rhs, []) + LT -> Nothing + | otherwise + = Nothing + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in TcRnExports.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = + case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + where + isSrcParent = isNoParent parent +isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) + = True -- #14058 +isTyConWithSrcDataCons _ = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) + = case rhs of + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. In any +-- other case, the function panics +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleDataCon_maybe _ = Nothing + +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + +tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon +-- Returns (Just con) for single-constructor +-- *algebraic* data types *not* newtypes +tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleAlgDataCon_maybe _ = Nothing + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) +tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) + +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res +tyConFamilyResVar_maybe _ = Nothing + +-- | Get the list of roles for the type parameters of a TyCon +tyConRoles :: TyCon -> [Role] +-- See also Note [TyCon Role signatures] +tyConRoles tc + = case tc of + { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] + ; AlgTyCon { tcRoles = roles } -> roles + ; SynonymTyCon { tcRoles = roles } -> roles + ; FamilyTyCon {} -> const_role Nominal + ; PrimTyCon { tcRoles = roles } -> roles + ; PromotedDataCon { tcRoles = roles } -> roles + ; TcTyCon {} -> const_role Nominal + } + where + const_role r = replicate (tyConArity tc) r + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) + = (tvs, rhs) +newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) + = length (fst tvs_rhs) +newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con +newTyConDataCon_maybe _ = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@ +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (FunTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav +famTyConFlav_maybe _ = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True +isClassTyCon _ = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas +tyConClass_maybe _ = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas +tyConATs _ = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) + = True +isFamInstTyCon _ = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) + = Just (f, ts, ax) +tyConFamInstSig_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) + = Just (f, ts) +tyConFamInst_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) + = Just ax +tyConFamilyCoercion_maybe _ = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo +tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri +tyConRuntimeRepInfo _ = NoRRI + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from constructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving Eq + +instance Outputable TyConFlavour where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (DataFamilyFlavour (Just _)) = "associated data family" + go (DataFamilyFlavour Nothing) = "data family" + go (OpenTypeFamilyFlavour (Just _)) = "associated type family" + go (OpenTypeFamilyFlavour Nothing) = "type family" + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + +tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | ClassTyCon _ _ <- parent = ClassFlavour + | otherwise = case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + AbstractTyCon {} -> AbstractTypeFlavour +tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) + = case flav of + DataFamilyTyCon{} -> DataFamilyFlavour parent + OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour +tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour +tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour +tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated ClassFlavour = False +tcFlavourMustBeSaturated DataTypeFlavour = False +tcFlavourMustBeSaturated NewtypeFlavour = False +tcFlavourMustBeSaturated DataFamilyFlavour{} = False +tcFlavourMustBeSaturated TupleFlavour{} = False +tcFlavourMustBeSaturated SumFlavour = False +tcFlavourMustBeSaturated AbstractTypeFlavour = False +tcFlavourMustBeSaturated BuiltInTypeFlavour = False +tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated TypeSynonymFlavour = True +tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True +tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True + +-- | Is this flavour of 'TyCon' an open type family or a data family? +tcFlavourIsOpen :: TyConFlavour -> Bool +tcFlavourIsOpen DataFamilyFlavour{} = True +tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc + = case tc of + PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types + _ -> empty + +instance NamedThing TyCon where + getName = tyConName + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" + +instance Binary Injectivity where + put_ bh NotInjective = putByte bh 0 + put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs + + get bh = do { h <- getByte bh + ; case h of + 0 -> return NotInjective + _ -> do { xs <- get bh + ; return (Injective xs) } } + +{- +************************************************************************ +* * + Walking over recursive TyCons +* * +************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that + * We can expand T, even though it's recursive. + * We can expand Id (Id Int), even though the Id shows up + twice at the outer level, because Id is non-recursive + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bail out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +More precisely, we keep a *count* of how many times we've seen it. +This is to account for + data instance T (a,b) = MkT (T a) (T b) +Then (#10482) if we have a type like + T (Int,(Int,(Int,(Int,Int)))) +we can still unbox deeply enough during strictness analysis. +We have to treat T as potentially recursive, but it's still +good to be able to unwrap multiple layers. + +The function that manages all this is checkRecTc. +-} + +data RecTcChecker = RC !Int (NameEnv Int) + -- The upper bound, and the number of times + -- we have encountered each TyCon + +-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. +initRecTc :: RecTcChecker +initRecTc = RC defaultRecTcMaxBound emptyNameEnv + +-- | The default upper bound (100) for the number of times a 'RecTcChecker' is +-- allowed to encounter each 'TyCon'. +defaultRecTcMaxBound :: Int +defaultRecTcMaxBound = 100 +-- Should we have a flag for this? + +-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed +-- to encounter each 'TyCon'. +setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker +setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC bound rec_nts) tc + = case lookupNameEnv rec_nts tc_name of + Just n | n >= bound -> Nothing + | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) + Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) + where + tc_name = tyConName tc + +-- | Returns whether or not this 'TyCon' is definite, or a hole +-- that may be filled in at some later point. See Note [Skolem abstract data] +tyConSkolem :: TyCon -> Bool +tyConSkolem = isHoleName . tyConName + +-- Note [Skolem abstract data] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Skolem abstract data arises from data declarations in an hsig file. +-- +-- The best analogy is to interpret the types declared in signature files as +-- elaborating to universally quantified type variables; e.g., +-- +-- unit p where +-- signature H where +-- data T +-- data S +-- module M where +-- import H +-- f :: (T ~ S) => a -> b +-- f x = x +-- +-- elaborates as (with some fake structural types): +-- +-- p :: forall t s. { f :: forall a b. t ~ s => a -> b } +-- p = { f = \x -> x } -- ill-typed +-- +-- It is clear that inside p, t ~ s is not provable (and +-- if we tried to write a function to cast t to s, that +-- would not work), but if we call p @Int @Int, clearly Int ~ Int +-- is provable. The skolem variables are all distinct from +-- one another, but we can't make assumptions like "f is +-- inaccessible", because the skolem variables will get +-- instantiated eventually! +-- +-- Skolem abstractness can apply to "non-abstract" data as well): +-- +-- unit p where +-- signature H1 where +-- data T = MkT +-- signature H2 where +-- data T = MkT +-- module M where +-- import qualified H1 +-- import qualified H2 +-- f :: (H1.T ~ H2.T) => a -> b +-- f x = x +-- +-- This is why the test is on the original name of the TyCon, +-- not whether it is abstract or not. diff --git a/compiler/GHC/Core/TyCon.hs-boot b/compiler/GHC/Core/TyCon.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCon.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.TyCon where + +import GhcPrelude + +data TyCon + +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Type.hs @@ -0,0 +1,3241 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 +-- +-- Type - public interface + +{-# LANGUAGE CPP, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Main functions for manipulating types and type-related things +module GHC.Core.Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, + KnotTied, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, + splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, + + mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + splitFunTy, splitFunTy_maybe, + splitFunTys, funResultTy, funArgTy, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, tyConAppArgN, + tcSplitTyConApp_maybe, + splitListTyConApp_maybe, + repSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInvForAllTy, mkInvForAllTys, + splitForAllTys, splitForAllTysSameVis, + splitForAllVarBndrs, + splitForAllTy_maybe, splitForAllTy, + splitForAllTy_ty_maybe, splitForAllTy_co_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + mkLamType, mkLamTypes, + piResultTy, piResultTys, + applyTysX, dropForAlls, + mkFamilyTyConApp, + buildSynTyCon, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + isLitTy, + + isPredTy, + + getRuntimeRep_maybe, kindRep_maybe, kindRep, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + discardCast, + + userTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, + + splitPiTysInvisible, splitPiTysInvisibleN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConArgFlags, appTyArgFlags, + synTyConResKind, + + modifyJoinResTy, setJoinResTy, + + -- ** Analyzing types + TyCoMapper(..), mapTyCo, mapTyCoX, + TyCoFolder(..), foldTyCo, + + -- (Newtypes) + newTyConInstRhs, + + -- ** Binders + sameVis, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinders, + mkAnonBinder, + isAnonTyCoBinder, + binderVar, binderVars, binderType, binderArgFlag, + tyCoBinderType, tyCoBinderVar_maybe, + tyBinderType, + binderRelevantType_maybe, + isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, + isInvisibleBinder, isNamedBinder, + tyConBindersTyCoBinders, + + -- ** Common type constructors + funTyCon, + + -- ** Predicates on types + isTyVarTy, isFunTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isPiTy, isTauTy, isFamFreeTy, + isCoVarType, + + isValidJoinPointType, + tyConAppNeedsKindSig, + + -- *** Levity and boxity + isLiftedType_maybe, + isLiftedTypeKind, isUnliftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, + isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isAlgType, isDataFamilyAppType, + isPrimitiveType, isStrictType, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + getRuntimeRep, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, + tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, + tcIsRuntimeTypeKind, + + -- ** Common Kind + liftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + + noFreeVarsOfType, + splitVisVarsOfType, splitVisVarsOfTypes, + expandTypeSynonyms, + typeSize, occCheckExpand, + + -- ** Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Well-scoped lists of variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Type comparison + eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, + nonDetCmpTypesX, nonDetCmpTc, + eqVarBndrs, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, tcView, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + TCvSubst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + + mkTCvSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemTCvSubst, + getTvSubstEnv, setTvSubstEnv, + zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstBinderAndInScope, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptyTCvSubst, unionTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyTyCoVarBinder, tidyTyCoVarBinders, + + -- * Kinds + isConstraintKindCon, + classifiesTypeWithValues, + isKindLevPoly + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Basic + +-- We import the representation and primitive functions from GHC.Core.TyCo.Rep. +-- Many things are reexported, but not the representation! + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs + +-- friends: +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set + +import GHC.Core.TyCon +import TysPrim +import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind + , typeSymbolKind, liftedTypeKind + , liftedTypeKindTyCon + , constraintKind ) +import GHC.Types.Name( Name ) +import PrelNames +import GHC.Core.Coercion.Axiom +import {-# SOURCE #-} GHC.Core.Coercion + ( mkNomReflCo, mkGReflCo, mkReflCo + , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo + , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo + , decomposePiCos, coercionKind, coercionLKind + , coercionRKind, coercionType + , isReflexiveCo, seqCo ) + +-- others +import Util +import FV +import Outputable +import FastString +import Pair +import ListSetOps +import GHC.Types.Unique ( nonDetCmpUnique ) + +import Maybes ( orElse ) +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) + +-- $type_classification +-- #type_classification# +-- +-- Types are one of: +-- +-- [Unboxed] Iff its representation is other than a pointer +-- Unboxed types are also unlifted. +-- +-- [Lifted] Iff it has bottom as an element. +-- Closures always have lifted types: i.e. any +-- let-bound identifier in Core must have a lifted +-- type. Operationally, a lifted object is one that +-- can be entered. +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. This is /not/ the same as +-- lifted types, because we also include unboxed +-- tuples in this classification. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ + +Note [coreView vs tcView] +~~~~~~~~~~~~~~~~~~~~~~~~~ +So far as the typechecker is concerned, 'Constraint' and 'TYPE +LiftedRep' are distinct kinds. + +But in Core these two are treated as identical. + +We implement this by making 'coreView' convert 'Constraint' to 'TYPE +LiftedRep' on the fly. The function tcView (used in the type checker) +does not do this. + +See also #11715, which tracks removing this inconsistency. + +-} + +-- | Gives the typechecker view of a type. This unwraps synonyms but +-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into +-- TYPE LiftedRep. Returns Nothing if no unwrapping happens. +-- See also Note [coreView vs tcView] +{-# INLINE tcView #-} +tcView :: Type -> Maybe Type +tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- The free vars of 'rhs' should all be bound by 'tenv', so it's + -- ok to use 'substTy' here. + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! +tcView _ = Nothing + +{-# INLINE coreView #-} +coreView :: Type -> Maybe Type +-- ^ This function Strips off the /top layer only/ of a type synonym +-- application (if any) its underlying representation type. +-- Returns Nothing if there is nothing to look through. +-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView ty@(TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- This equation is exactly like tcView + + -- At the Core level, Constraint = Type + -- See Note [coreView vs tcView] + | isConstraintKindCon tc + = ASSERT2( null tys, ppr ty ) + Just liftedTypeKind + +coreView _ = Nothing + +----------------------------------------------- +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptyTCvSubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ arg res) + = ty { ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + go_co subst (ForAllCo tv kind_co co) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' kind_co' (go_co subst' co) + go_co subst (FunCo r co1 co2) + = mkFunCo r (go_co subst co1) (go_co subst co2) + go_co subst (CoVarCo cv) + = substCoVar subst cv + go_co subst (AxiomInstCo ax ind args) + = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (UnivCo p r t1 t2) + = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (NthCo r n co) + = mkNthCo r n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co subst (AxiomRuleCo ax cs) + = AxiomRuleCo ax (map (go_co subst) cs) + go_co _ (HoleCo h) + = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) + go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) + go_prov _ p@(PluginProv _) = p + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrUsing, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- order of a coercion) + go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> Type +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +-- Treats * and Constraint as the same +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindRep_maybe kind + | Just kind' <- coreView kind = kindRep_maybe kind' + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +-- | This version considers Constraint to be the same as *. Returns True +-- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +isLiftedRuntimeRep :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeRep rep + | Just rep' <- coreView rep = isLiftedRuntimeRep rep' + | TyConApp rr_tc args <- rep + , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | otherwise = False + +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +isUnliftedRuntimeRep :: Type -> Bool +-- True of definitely-unlifted RuntimeReps +-- False of (LiftedRep :: RuntimeRep) +-- and of variables (a :: RuntimeRep) +isUnliftedRuntimeRep rep + | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' + | TyConApp rr_tc _ <- rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' +isRuntimeRepTy (TyConApp tc args) + | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True +isRuntimeRepTy _ = False + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + + +{- ********************************************************************* +* * + mapType +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for ForAllCo case of mapTyCoX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used +to implement zonking, and it's vital that they get specialised to the TcM +monad and the particular mapper in use. + +Even specialising to the monad alone made a 20% allocation difference +in perf/compiler/T5030. + +See Note [Specialising foldType] in TyCoRep for more details of this +idiom. +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep. + + , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in TcTyClsDecls + } + +{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] +mapTyCo :: Monad m => TyCoMapper () m + -> ( Type -> m Type + , [Type] -> m [Type] + , Coercion -> m Coercion + , [Coercion] -> m[Coercion]) +mapTyCo mapper + = case mapTyCoX mapper of + (go_ty, go_tys, go_co, go_cos) + -> (go_ty (), go_tys (), go_co (), go_cos ()) + +{-# INLINE mapTyCoX #-} -- See Note [Specialising mappers] +mapTyCoX :: Monad m => TyCoMapper env m + -> ( env -> Type -> m Type + , env -> [Type] -> m [Type] + , env -> Coercion -> m Coercion + , env -> [Coercion] -> m[Coercion]) +mapTyCoX (TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon + , tcm_covar = covar + , tcm_hole = cohole }) + = (go_ty, go_tys, go_co, go_cos) + where + go_tys _ [] = return [] + go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys + + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 + go_ty _ ty@(LitTy {}) = return ty + go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co + go_ty env (CoercionTy co) = CoercionTy <$> go_co env co + + go_ty env ty@(FunTy _ arg res) + = do { arg' <- go_ty env arg; res' <- go_ty env res + ; return (ty { ft_arg = arg', ft_res = res' }) } + + go_ty env ty@(TyConApp tc tys) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> go_tys env tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> go_tys env tys + + go_ty env (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis + ; inner' <- go_ty env' inner + ; return $ ForAllTy (Bndr tv' vis) inner' } + + go_cos _ [] = return [] + go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos + + go_mco _ MRefl = return MRefl + go_mco env (MCo co) = MCo <$> (go_co env co) + + go_co env (Refl ty) = Refl <$> go_ty env ty + go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco + go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 + go_co env (FunCo r c1 c2) = mkFunCo r <$> go_co env c1 <*> go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r + <*> go_ty env t1 <*> go_ty env t2 + go_co env (SymCo co) = mkSymCo <$> go_co env co + go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 + go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos + go_co env (NthCo r i co) = mkNthCo r i <$> go_co env co + go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co + go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg + go_co env (KindCo co) = mkKindCo <$> go_co env co + go_co env (SubCo co) = mkSubCo <$> go_co env co + go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos + go_co env co@(TyConAppCo r tc cos) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConAppCo r tc' <$> go_cos env cos } + + -- Not a TcTyCon + | null cos -- Avoid allocation in this very + = return co -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConAppCo r tc <$> go_cos env cos + go_co env (ForAllCo tv kind_co co) + = do { kind_co' <- go_co env kind_co + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- go_co env' co + ; return $ mkForAllCo tv' kind_co' co' } + -- See Note [Efficiency for ForAllCo case of mapTyCoX] + + go_prov env (PhantomProv co) = PhantomProv <$> go_co env co + go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co + go_prov _ p@(PluginProv _) = return p + + +{- +************************************************************************ +* * +\subsection{Constructor-specific functions} +* * +************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ +-} + +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' +getTyVar :: String -> Type -> TyVar +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' + | otherwise = repGetTyVar_maybe ty + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind ty +getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' +getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) +getCastedTyVar_maybe (TyVarTy tv) + = Just (tv, mkReflCo Nominal (tyVarKind tv)) +getCastedTyVar_maybe _ = Nothing + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +{- +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) Eq a) which doesn't make sense in +source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (#9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +up decomposing (Eq Int => Int), and we definitely don't want that. + +This really only applies to the type checker; in Core, '=>' and '->' +are the same, as are 'Constraint' and '*'. But for now I've put +the test in repSplitAppTy_maybe, which applies throughout, because +the other calls to splitAppTy are in GHC.Core.Unify, which is also used by +the type checker (e.g. when matching type-function equations). + +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in TcHsTypes.tcInferApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in GHC.Core.TyCo.Rep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe ty | Just ty' <- coreView ty + = splitAppTy_maybe ty' +splitAppTy_maybe ty = repSplitAppTy_maybe ty + +------------- +repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any Core view stuff is already done +repSplitAppTy_maybe (FunTy _ ty1 ty2) + = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +repSplitAppTy_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +repSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! + +repSplitAppTy_maybe _other = Nothing + +-- This one doesn't break apart (c => t). +-- See Note [Decomposing fat arrow c=>t] +-- Defined here to avoid module loops between Unify and TcType. +tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that +-- any coreView stuff is already done. Refuses to look through (c => t) +tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) + | InvisArg <- af + = Nothing -- See Note [Decomposing fat arrow c=>t] + + | otherwise + = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcRepSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! +tcRepSplitAppTy_maybe _other = Nothing + +------------- +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +------------- +splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy _ ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) +repSplitAppTys ty = split ty [] + where + split (AppTy ty arg) args = split ty (arg:args) + split (TyConApp tc tc_args) args + = let n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy _ ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split ty args = (ty, args) + +{- + LitTy + ~~~~~ +-} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 +isNumLitTy (LitTy (NumTyLit n)) = Just n +isNumLitTy _ = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 +isStrLitTy (LitTy (StrTyLit s)) = Just s +isStrLitTy _ = Nothing + +-- | Is this a type literal (symbol or numeric). +isLitTy :: Type -> Maybe TyLit +isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 +isLitTy (LitTy l) = Just l +isLitTy _ = Nothing + +-- | Is this type a custom user error? +-- If so, give us the kind and the error message. +userTypeError_maybe :: Type -> Maybe Type +userTypeError_maybe t + = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + + ; guard (tyConName tc == errorMessageTypeErrorFamName) + ; return msg } + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: Type -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + + + + +{- +--------------------------------------------------------------------- + FunTy + ~~~~~ + +Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Functions (e.g. Int -> Char) can be thought of as being applications +of funTyCon (known in Haskell surface syntax as (->)), + + (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when recontructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +See #11714. +-} + +splitFunTy :: Type -> (Type, Type) +-- ^ Attempts to extract the argument and result types from a type, and +-- panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' +splitFunTy (FunTy _ arg res) = (arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) + +splitFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempts to extract the argument and result types from a type +splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' +splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) +splitFunTy_maybe _ = Nothing + +splitFunTys :: Type -> ([Type], Type) +splitFunTys ty = split [] ty ty + where + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args _ (FunTy _ arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty | Just ty' <- coreView ty = funResultTy ty' +funResultTy (FunTy { ft_res = res }) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty | Just ty' <- coreView ty = funArgTy ty' +funArgTy (FunTy { ft_arg = arg }) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg + | Just ty' <- coreView ty = piResultTy_maybe ty' arg + + | FunTy { ft_res = res } <- ty + = Just res + + | ForAllTy (Bndr tv _) res <- ty + = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + | otherwise + = Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: TCvSubst -> Type -> [Type] -> Type + go subst ty [] = substTyUnchecked subst ty + + go subst ty all_args@(arg:args) + | Just ty' <- coreView ty + = go subst ty' all_args + + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infinite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) + ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) + mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) + (drop n_tvs arg_tys) + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + n_tvs = length tvs + + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must instantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. + +-------------------------------------- +Note [mkTyConApp and Type] + +Whilst benchmarking it was observed in #17292 that GHC allocated a lot +of `TyConApp` constructors. Upon further inspection a large number of these +TyConApp constructors were all duplicates of `Type` applied to no arguments. + +``` +(From a sample of 100000 TyConApp closures) +0x45f3523 - 28732 - `Type` +0x420b840702 - 9629 - generic type constructors +0x42055b7e46 - 9596 +0x420559b582 - 9511 +0x420bb15a1e - 9509 +0x420b86c6ba - 9501 +0x42055bac1e - 9496 +0x45e68fd - 538 - `TYPE ...` +``` + +Therefore in `mkTyConApp` we have a special case for `Type` to ensure that +only one `TyConApp 'Type []` closure is allocated during the course of +compilation. In order to avoid a potentially expensive series of checks in +`mkTyConApp` only this egregious case is special cased at the moment. + + +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon + , [_rep1,_rep2,ty1,ty2] <- tys + -- The FunTyCon (->) is always a visible one + = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } + -- Note [mkTyConApp and Type] + | tycon == liftedTypeKindTyCon + = ASSERT2( null tys, ppr tycon $$ ppr tys ) + liftedTypeKindTyConApp + | otherwise + = TyConApp tycon tys + +-- This is a single, global definition of the type `Type` +-- Defined here so it is only allocated once. +-- See Note [mkTyConApp and Type] +liftedTypeKindTyConApp :: Type +liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon +tyConAppTyConPicky_maybe _ = Nothing + + +-- | The same as @fst . splitTyConApp@ +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' +tyConAppTyCon_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (FunTy {}) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing + +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (FunTy _ arg res) + | Just rep1 <- getRuntimeRep_maybe arg + , Just rep2 <- getRuntimeRep_maybe res + = Just [rep1, rep2, arg, res] +tyConAppArgs_maybe _ = Nothing + +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) + +tyConAppArgN :: Int -> Type -> Type +-- Executing Nth +tyConAppArgN n ty + = case tyConAppArgs_maybe ty of + Just tys -> tys `getNth` n + Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' +splitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +-- | Split a type constructor application into its type constructor and +-- applied types. Note that this may fail in the case of a 'FunTy' with an +-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind +-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your +-- type before using this function. +-- +-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. +tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' +tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +------------------- +repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. +-- +-- Moreover, for a FunTy, it only succeeds if the argument types +-- have enough info to extract the runtime-rep arguments that +-- the funTyCon requires. This will usually be true; +-- but may be temporarily false during canonicalization: +-- see Note [FunTy and decomposing tycon applications] in TcCanonical +-- +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (FunTy _ arg res) + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + = Just (funTyCon, [arg_rep, res_rep, arg, res]) +repSplitTyConApp_maybe _ = Nothing + +------------------- +-- | Attempts to tease a list type apart and gives the type of the elements if +-- successful (looks through type synonyms) +splitListTyConApp_maybe :: Type -> Maybe Type +splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of + Just (tc,[e]) | tc == listTyCon -> Just e + _other -> Nothing + +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + +{- +--------------------------------------------------------------------- + CastTy + ~~~~~~ +A casted type has its *kind* casted into something new. +-} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' +splitCastTy_maybe (CastTy ty co) = Just (ty, co) +splitCastTy_maybe _ = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See Note [Respecting definitional equality] in GHC.Core.TyCo.Rep +mkCastTy :: Type -> Coercion -> Type +mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. + +mkCastTy (CastTy ty co1) co2 + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co2) + -- call mkCastTy again for the reflexivity check + +mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co + -- (EQ4) from the Note + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) + else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) + +mkCastTy ty co = CastTy ty co + +tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] +-- Return the tyConBinders in TyCoBinder form +tyConBindersTyCoBinders = map to_tyb + where + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) + +-- | Drop the cast on a type, if any. If there is no +-- cast, just return the original type. This is rarely what +-- you want. The CastTy data constructor (in GHC.Core.TyCo.Rep) has the +-- invariant that another CastTy is not inside. See the +-- data constructor for a full description of this invariant. +-- Since CastTy cannot be nested, the result of discardCast +-- cannot be a CastTy. +discardCast :: Type -> Type +discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty + where + isCastTy CastTy{} = True + isCastTy _ = False +discardCast ty = ty + + +{- +-------------------------------------------------------------------- + CoercionTy + ~~~~~~~~~~ +CoercionTy allows us to inject coercions into types. A CoercionTy +should appear only in the right-hand side of an application. +-} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + +{- +--------------------------------------------------------------------- + SynTy + ~~~~~ + +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. + + +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ +-} + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkVisFunTy (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInvForAllTy :: TyVar -> Type -> Type +mkInvForAllTy tv ty = ASSERT( isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInvForAllTys :: [TyVar] -> Type -> Type +mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +mkLamType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or an implicit forall type, depending +-- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. +-- Always uses Inferred binders. +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = ForAllTy (Bndr v Inferred) body_ty + + | isCoVar v + , v `elemVarSet` tyCoVarsOfType body_ty + = ForAllTy (Bndr v Required) body_ty + + | isPredTy arg_ty -- See Note [mkLamType: dictionary arguments] + = mkInvisFunTy arg_ty body_ty + + | otherwise + = mkVisFunTy arg_ty body_ty + where + arg_ty = varType v + +mkLamTypes vs ty = foldr mkLamType ty vs + +{- Note [mkLamType: dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (\ (d :: Ord a). blah), we want to give it type + (Ord a => blah_ty) +with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. + +Why? After all, we are in Core, where (=>) and (->) behave the same. +Yes, but the /specialiser/ does treat dictionary arguments specially. +Suppose we do w/w on 'foo' in module A, thus (#11272, #6056) + foo :: Ord a => Int -> blah + foo a d x = case x of I# x' -> $wfoo @a d x' + + $wfoo :: Ord a => Int# -> blah + +Now in module B we see (foo @Int dOrdInt). The specialiser will +specialise this to $sfoo, where + $sfoo :: Int -> blah + $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' + +Now we /must/ also specialise $wfoo! But it wasn't user-written, +and has a type built with mkLamTypes. + +Conclusion: the easiest thing is to make mkLamType build + (c => ty) +when the argument is a predicate type. See GHC.Core.TyCo.Rep +Note [Types for coercions, predicates, and evidence] +-} + +-- | Given a list of type-level vars and the free vars of a result kind, +-- makes TyCoBinders, preferring anonymous binders +-- if the variable is, in fact, not dependent. +-- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Bndr v (AnonTCB VisArg) : binders + , fvs `unionVarSet` kind_vars ) + where + (binders, fvs) = go vs + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTys :: Type -> ([TyCoVar], Type) +splitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTys', but only splits a 'ForAllTy' if +-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility +-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided +-- as an argument to this function. +splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) +splitForAllTysSameVis supplied_argf ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv argf) ty) tvs + | argf `sameVis` supplied_argf = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like splitForAllTys, but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitTyVarForAllTys :: Type -> ([TyVar], Type) +splitTyVarForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' +isForAllTy (ForAllTy {}) = True +isForAllTy _ = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' +isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True +isForAllTy_ty _ = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' +isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True +isForAllTy_co _ = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty | Just ty' <- coreView ty = isPiTy ty' +isPiTy (ForAllTy {}) = True +isPiTy (FunTy {}) = True +isPiTy _ = False + +-- | Is this a function? +isFunTy :: Type -> Bool +isFunTy ty | Just ty' <- coreView ty = isFunTy ty' +isFunTy (FunTy {}) = True +isFunTy _ = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTy :: Type -> (TyCoVar, Type) +splitForAllTy ty + | Just answer <- splitForAllTy_maybe ty = answer + | otherwise = pprPanic "splitForAllTy" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy _ res) = go res + go res = res + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder +splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. +splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_ty_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. +splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_co_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) + go _ = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) +splitPiTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy bndr ty) = Just (Named bndr, ty) + go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) + = Just (Anon af arg, res) + go _ = Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (TyCoBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all TyCoBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyCoBinder], Type) +splitPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs + = split res res (Anon af arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders +-- and returns TyCoVarBinders rather than TyCoBinders +splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) +splitForAllVarBndrs ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllVarBndrs #-} + +invisibleTyBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) + +-- Like splitPiTys, but returns only *invisible* binders, including constraints +-- Stops at the first visible binder +splitPiTysInvisible :: Type -> ([TyCoBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleArgFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs + = split res res (Anon InvisArg arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) +-- Same as splitPiTysInvisible, but stop when +-- - you have found 'n' TyCoBinders, +-- - or you run out of invisible binders +splitPiTysInvisibleN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty + = split (n-1) res res (Anon InvisArg arg : bs) + | otherwise = (reverse bs, orig_ty) + +-- | Given a 'TyCon' and a list of argument types, filter out any invisible +-- (i.e., 'Inferred' or 'Specified') arguments. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc tys = + partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys + +-- | Given a list of things paired with their visibilities, partition the +-- things into (invisible things, visible things). +partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + pick_invis :: (a, ArgFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing + | otherwise = Right thing + +-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] +tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) + +-- | Given a 'Type' and a list of argument types to which the 'Type' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Most of the time, the arguments will be 'Required', but not always. Consider +-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is +-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely +-- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +appTyArgFlags :: Type -> [Type] -> [ArgFlag] +appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) + +-- | Given a function kind and a list of argument types (where each argument's +-- kind aligns with the corresponding position in the argument kind), determine +-- each argument's visibility ('Inferred', 'Specified', or 'Required'). +fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] +fun_kind_arg_flags = go emptyTCvSubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + -- This FunTy case is important to handle kinds with nested foralls, such + -- as this kind (inspired by #16518): + -- + -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type + -- + -- Here, we want to get the following ArgFlags: + -- + -- [Inferred, Specified, Required, Required, Specified, Required] + -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type + go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) + = argf : go subst res_ki arg_tys + where + argf = case af of + VisArg -> Required + InvisArg -> Inferred + go _ _ arg_tys = map (const Required) arg_tys + -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is Required. + +-- @isTauTy@ tests if a type has no foralls +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy _ a b) = isTauTy a && isTauTy b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy ty _) = isTauTy ty +isTauTy (CoercionTy _) = False -- Not sure about this + +{- +%************************************************************************ +%* * + TyCoBinders +%* * +%************************************************************************ +-} + +-- | Make an anonymous binder +mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder +mkAnonBinder = Anon + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonTyCoBinder :: TyCoBinder -> Bool +isAnonTyCoBinder (Named {}) = False +isAnonTyCoBinder (Anon {}) = True + +tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar +tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv +tyCoBinderVar_maybe _ = Nothing + +tyCoBinderType :: TyCoBinder -> Type +tyCoBinderType (Named tvb) = binderType tvb +tyCoBinderType (Anon _ ty) = ty + +tyBinderType :: TyBinder -> Type +tyBinderType (Named (Bndr tv _)) + = ASSERT( isTyVar tv ) + tyVarKind tv +tyBinderType (Anon _ ty) = ty + +-- | Extract a relevant type, if there is one. +binderRelevantType_maybe :: TyCoBinder -> Maybe Type +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon _ ty) = Just ty + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +isFamFreeTy (CastTy ty _) = isFamFreeTy ty +isFamFreeTy (CoercionTy _) = False -- Not sure about this + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +isCoVarType :: Type -> Bool + -- ToDo: should we check saturation? +isCoVarType ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon +-- This function is here beucase here is where we have +-- isFamFree and isTauTy +buildSynTyCon name binders res_kind roles rhs + = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + where + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Returns Just True if this type is surely lifted, Just False +-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is +-- levity polymorphic), and panics if the kind does not have the shape +-- TYPE r. +isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool +isLiftedType_maybe ty = go (getRuntimeRep ty) + where + go rr | Just rr' <- coreView rr = go rr' + | isLiftedRuntimeRep rr = Just True + | TyConApp {} <- rr = Just False -- Everything else is unlifted + | otherwise = Nothing -- levity polymorphic + +-- | See "Type#type_classification" for what an unlifted type is. +-- Panics on levity polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- levity polymorphism. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- isUnliftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them +isUnliftedType ty + = not (isLiftedType_maybe ty `orElse` + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ lifted or +-- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case) +mightBeUnliftedType :: Type -> Bool +mightBeUnliftedType ty + = case isLiftedType_maybe ty of + Just is_lifted -> not is_lifted + Nothing -> True + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe Type +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> Type +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | Check whether a type is a data family type +isDataFamilyAppType :: Type -> Bool +isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in GHC.Core.) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) + | Just (t, ty') <- splitForAllTy_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +GHC.Core), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use repSplitAppTy_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +-} + +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@ or +-- 'PredType's, but it does look through type synonyms. +-- This first checks that the kinds of the types are equal and then +-- checks whether the types are equal, ignoring casts and coercions. +-- (The kind check is a recursive call, but since all kinds have type +-- @Type@, there is no need to check the types of kinds.) +-- See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. +eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 + -- It's OK to use nonDetCmpType here and eqType is deterministic, + -- nonDetCmpType does equality deterministically + +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 + -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, + -- nonDetCmpTypeX does equality deterministically + +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 + -- It's OK to use nonDetCmpType here and eqTypes is deterministic, + -- nonDetCmpTypes does equality deterministically + +eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing + +-- Now here comes the real worker + +{- +Note [nonDetCmpType nondeterminism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = nonDetCmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) + +nonDetCmpTypes :: [Type] -> [Type] -> Ordering +nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) + +-- | An ordering relation between two 'Type's (known below as @t1 :: k1@ +-- and @t2 :: k2@) +data TypeOrdering = TLT -- ^ @t1 < t2@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep +nonDetCmpTypeX env orig_t1 orig_t2 = + case go env orig_t1 orig_t2 of + -- If there are casts then we also need to do a comparison of the kinds of + -- the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- Returns both the resulting ordering relation between the two types + -- and whether either contains a cast. + go :: RnEnv2 -> Type -> Type -> TypeOrdering + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 + go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) + = go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- repSplitAppTy_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- repSplitAppTy_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (FunTy _ s1 t1) (FunTy _ s2 t2) + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + gos _ _ [] = TGT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 + +------------- +nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +nonDetCmpTypesX _ [] [] = EQ +nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 + `thenCmp` + nonDetCmpTypesX env tys1 tys2 +nonDetCmpTypesX _ [] _ = LT +nonDetCmpTypesX _ _ [] = GT + +------------- +-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as +-- recognized by Kind.isConstraintKindCon) which is considered a synonym for +-- 'Type' in Core. +-- See Note [Kind Constraint and kind Type] in Kind. +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) + u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [typeKind vs tcTypeKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two functions to get the kind of a type + + * typeKind ignores the distinction between Constraint and * + * tcTypeKind respects the distinction between Constraint and * + +tcTypeKind is used by the type inference engine, for which Constraint +and * are different; after that we use typeKind. + +See also Note [coreView vs tcView] + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. +We then have + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + ty : TYPE rep + `a` is not free in rep +(FORALL) ----------------------- + forall a. ty : TYPE rep + +In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + t1 : Constraint + t2 : TYPE rep + (PRED1) ---------------- + t1 => t2 : Type + + t1 : Constraint + t2 : Constraint + (PRED2) --------------------- + t1 => t2 : Constraint + + ty : TYPE rep + `a` is not free in rep +(FORALL1) ----------------------- + forall a. ty : TYPE rep + + ty : Constraint +(FORALL2) ------------------------- + forall a. ty : Constraint + +Note that: +* The only way we distinguish '->' from '=>' is by the fact + that the argument is a PredTy. Both are FunTys + +Note [Phantom type variables in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +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 + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +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. +-} + +----------------------------- +typeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (LitTy l) = typeLiteralKind l +typeKind (FunTy {}) = liftedTypeKind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = coercionRKind co +typeKind (CoercionTy co) = coercionType co + +typeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (typeKind fun) args + +typeKind ty@(ForAllTy {}) + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = typeKind body + +--------------------------------------------- +-- Utilities to be used in GHC.Core.Unify, +-- which uses "tc" functions +--------------------------------------------- + +tcTypeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +tcTypeKind (LitTy l) = typeLiteralKind l +tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar +tcTypeKind (CastTy _ty co) = coercionRKind co +tcTypeKind (CoercionTy co) = coercionType co + +tcTypeKind (FunTy { ft_af = af, ft_res = res }) + | InvisArg <- af + , tcIsConstraintKind (tcTypeKind res) + = constraintKind -- Eq a => Ord a :: Constraint + | otherwise -- Eq a => a -> a :: TYPE LiftedRep + = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) + +tcTypeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (tcTypeKind fun) args + +tcTypeKind ty@(ForAllTy {}) + | tcIsConstraintKind body_kind + = constraintKind + + | otherwise + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "tcTypeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = tcTypeKind body + + +isPredTy :: HasDebugCallStack => Type -> Bool +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +isPredTy ty = tcIsConstraintKind (tcTypeKind ty) + +-- tcIsConstraintKind stuff only makes sense in the typechecker +-- After that Constraint = Type +-- See Note [coreView vs tcView] +-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) +tcIsConstraintKind :: Kind -> Bool +tcIsConstraintKind ty + | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , isConstraintKindCon tc + = ASSERT2( null args, ppr ty ) True + + | otherwise + = False + +-- | Is this kind equivalent to @*@? +-- +-- This considers 'Constraint' to be distinct from @*@. For a version that +-- treats them as the same type, see 'isLiftedTypeKind'. +tcIsLiftedTypeKind :: Kind -> Bool +tcIsLiftedTypeKind ty + | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = isLiftedRuntimeRep arg + | otherwise + = False + +-- | Is this kind equivalent to @TYPE r@ (for some unknown r)? +-- +-- This considers 'Constraint' to be distinct from @*@. +tcIsRuntimeTypeKind :: Kind -> Bool +tcIsRuntimeTypeKind ty + | Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = True + | otherwise + = False + +tcReturnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +tcReturnsConstraintKind kind + | Just kind' <- tcView kind = tcReturnsConstraintKind kind' +tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc +tcReturnsConstraintKind _ = False + +-------------------------- +typeLiteralKind :: TyLit -> Kind +typeLiteralKind (NumTyLit {}) = typeNatKind +typeLiteralKind (StrTyLit {}) = typeSymbolKind + +-- | Returns True if a type is levity polymorphic. Should be the same +-- as (isKindLevPoly . typeKind) but much faster. +-- Precondition: The type has kind (TYPE blah) +isTypeLevPoly :: Type -> Bool +isTypeLevPoly = go + where + go ty@(TyVarTy {}) = check_kind ty + go ty@(AppTy {}) = check_kind ty + go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False + | otherwise = check_kind ty + go (ForAllTy _ ty) = go ty + go (FunTy {}) = False + go (LitTy {}) = False + go ty@(CastTy {}) = check_kind ty + go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) + + check_kind = isKindLevPoly . typeKind + +-- | Looking past all pi-types, is the end result potentially levity polymorphic? +-- Example: True for (forall r (a :: TYPE r). String -> a) +-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) +resultIsLevPoly :: Type -> Bool +resultIsLevPoly = isTypeLevPoly . snd . splitPiTys + + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + | null vs_to_avoid -- Efficient shortcut + = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase + + | otherwise + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go cxt@(as, env) (TyVarTy tv') + | tv' `elemVarSet` as = Nothing + | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') + | otherwise = do { tv'' <- go_var cxt tv' + ; return (mkTyVarTy tv'') } + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkAppTy ty1' ty2') } + go cxt ty@(FunTy _ ty1 ty2) + = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (mkTyConApp tc tys') + Nothing | Just ty' <- tcView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (mkCastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (mkCoercionTy co') } + + ------------------ + go_var cxt v = do { k' <- go cxt (varType v) + ; return (setVarType v k') } + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (mkNomReflCo ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (mkGReflCo r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (mkTyConAppCo r tc args') } + go_co cxt (AppCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkAppCo co' arg') } + go_co cxt@(as, env) (ForAllCo tv kind_co body_co) + = do { kind_co' <- go_co cxt kind_co + ; let tv' = setVarType tv $ + coercionLKind kind_co' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_co (as', env') body_co + ; return (ForAllCo tv' kind_co' body') } + go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkFunCo r co1' co2') } + go_co cxt@(as,env) (CoVarCo c) + | c `elemVarSet` as = Nothing + | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') + | otherwise = do { c' <- go_var cxt c + ; return (mkCoVarCo c') } + go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) + ; return (HoleCo (h { ch_co_var = c' })) } + go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args + ; return (mkAxiomInstCo ax ind args') } + go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkUnivCo p' r ty1' ty2') } + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (mkSymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkTransCo co1' co2') } + go_co cxt (NthCo r n co) = do { co' <- go_co cxt co + ; return (mkNthCo r n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (mkLRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkInstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (mkKindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (mkSubCo co') } + go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (mkAxiomRuleCo ax cs') } + + ------------------ + go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co + go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co + go_prov _ p@(PluginProv _) = return p + + +{- +%************************************************************************ +%* * + Miscellaneous functions +%* * +%************************************************************************ + +-} +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco + go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args + go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co + go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_mco MRefl = emptyUniqSet + go_mco (MCo co) = go_co co + + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyUniqSet + -- this last case can happen from the tyConsOfType used from + -- checkTauTvUpdate + + go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys + go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + go_ax ax = go_tc $ coAxiomTyCon ax + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) + +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +splitVisVarsOfType :: Type -> Pair TyCoVarSet +splitVisVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ t1 t2) = go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitVisVarsOfTypes = foldMap splitVisVarsOfType + +modifyJoinResTy :: Int -- Number of binders to skip + -> (Type -> Type) -- Function to apply to result type + -> Type -- Type of join point + -> Type -- New type +-- INVARIANT: If any of the first n binders are foralls, those tyvars cannot +-- appear in the original result type. See isValidJoinPointType. +modifyJoinResTy orig_ar f orig_ty + = go orig_ar orig_ty + where + go 0 ty = f ty + go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty + = mkPiTy arg_bndr (go (n-1) res_ty) + | otherwise + = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) + +setJoinResTy :: Int -- Number of binders to skip + -> Type -- New result type + -> Type -- Type of join point + -> Type -- New type +-- INVARIANT: Same as for modifyJoinResTy +setJoinResTy ar new_res_ty ty + = modifyJoinResTy ar (const new_res_ty) ty + +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ + +Note [Kind Constraint and kind Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The kind Constraint is the kind of classes and other type constraints. +The special thing about types of kind Constraint is that + * They are displayed with double arrow: + f :: Ord a => a -> a + * They are implicitly instantiated at call sites; so the type inference + engine inserts an extra argument of type (Ord a) at every call site + to f. + +However, once type inference is over, there is *no* distinction between +Constraint and Type. Indeed we can have coercions between the two. Consider + class C a where + op :: a -> a +For this single-method class we may generate a newtype, which in turn +generates an axiom witnessing + C a ~ (a -> a) +so on the left we have Constraint, and on the right we have Type. +See #7451. + +Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with +distinct uniques, they are treated as equal at all times except +during type inference. +-} + +isConstraintKindCon :: TyCon -> Bool +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey + +-- | Tests whether the given kind (which should look like @TYPE x@) +-- is something other than a constructor tree (that is, constructors at every node). +-- E.g. True of TYPE k, TYPE (F Int) +-- False of TYPE 'LiftedRep +isKindLevPoly :: Kind -> Bool +isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) + -- the isLiftedTypeKind check is necessary b/c of Constraint + go k + where + go ty | Just ty' <- coreView ty = go ty' + go TyVarTy{} = True + go AppTy{} = True -- it can't be a TyConApp + go (TyConApp tc tys) = isFamilyTyCon tc || any go tys + go ForAllTy{} = True + go (FunTy _ t1 t2) = go t1 || go t2 + go LitTy{} = False + go CastTy{} = True + go CoercionTy{} = True + + _is_type = classifiesTypeWithValues k + +----------------------------------------- +-- Subkinding +-- The tc variants are used during type-checking, where ConstraintKind +-- is distinct from all other kinds +-- After type-checking (in core), Constraint and liftedTypeKind are +-- indistinguishable + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, #, TYPE Lifted, TYPE v, Constraint. +classifiesTypeWithValues :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +classifiesTypeWithValues k = isJust (kindRep_maybe k) + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. + +-} + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice + (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` + injectiveVarsOfType False (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) +2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in TcSplice), and sometimes the +omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, +which reifies specified arguments through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavey, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parametrized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Type.hs-boot @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Type where + +import GhcPrelude +import GHC.Core.TyCon +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) +import Util + +isPredTy :: HasDebugCallStack => Type -> Bool +isCoercionTy :: Type -> Bool + +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type +piResultTy :: HasDebugCallStack => Type -> Type -> Type + +eqType :: Type -> Type -> Bool + +coreView :: Type -> Maybe Type +tcView :: Type -> Maybe Type +isRuntimeRepTy :: Type -> Bool +isLiftedTypeKind :: Type -> Bool + +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) + +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -48,25 +48,25 @@ import GHC.Driver.Session import GHC.Core -import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) +import GHC.Core.Op.OccurAnal ( occurAnalyseExpr_NoBinderSwap ) import GHC.Core.SimpleOpt -import GHC.Core.Arity ( manifestArity ) +import GHC.Core.Arity ( manifestArity ) import GHC.Core.Utils -import Id -import Demand ( isBottomingSig ) -import DataCon -import Literal +import GHC.Types.Id +import GHC.Types.Demand ( isBottomingSig ) +import GHC.Core.DataCon +import GHC.Types.Literal import PrimOp -import IdInfo -import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) -import Type +import GHC.Types.Id.Info +import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec ) +import GHC.Core.Type import PrelNames import TysPrim ( realWorldStatePrimTy ) import Bag import Util import Outputable -import ForeignCall -import Name +import GHC.Types.ForeignCall +import GHC.Types.Name import ErrUtils import qualified Data.ByteString as BS @@ -121,7 +121,7 @@ , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding --- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap +-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Op.WorkWrap mkWorkerUnfolding dflags work_fn (CoreUnfolding { uf_src = src, uf_tmpl = tmpl , uf_is_top = top_lvl }) @@ -537,7 +537,7 @@ Note [Do not inline top-level bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The FloatOut pass has gone to some trouble to float out calls to 'error' -and similar friends. See Note [Bottoming floats] in SetLevels. +and similar friends. See Note [Bottoming floats] in GHC.Core.Op.SetLevels. Do not re-inline them! But we *do* still inline if they are very small (the uncondInline stuff). @@ -590,7 +590,7 @@ unconditional-inline thing for *trivial* expressions. NB: you might think that PostInlineUnconditionally would do this - but it doesn't fire for top-level things; see SimplUtils + but it doesn't fire for top-level things; see GHC.Core.Op.Simplify.Utils Note [Top level and postInlineUnconditionally] Note [Count coercion arguments in boring contexts] diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Unify.hs @@ -0,0 +1,1588 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Core.Unify ( + tcMatchTy, tcMatchTyKi, + tcMatchTys, tcMatchTyKis, + tcMatchTyX, tcMatchTysX, tcMatchTyKisX, + tcMatchTyX_BM, ruleMatchTyKiX, + + -- * Rough matching + roughMatchTcs, instanceCantMatch, + typesCantMatch, + + -- Side-effect free unification + tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, + tcUnifyTysFG, tcUnifyTyWithTFs, + BindFlag(..), + UnifyResult, UnifyResultM(..), + + -- Matching a type against a lifted type (coercion) + liftCoMatch + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name( Name ) +import GHC.Core.Type hiding ( getTvSubstEnv ) +import GHC.Core.Coercion hiding ( getCvSubstEnv ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import GHC.Core.TyCo.Subst ( mkTvSubst ) +import FV( FV, fvVarSet, fvVarList ) +import Util +import Pair +import Outputable +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set + +import Control.Monad +import Control.Applicative hiding ( empty ) +import qualified Control.Applicative + +{- + +Unification is much tricker than you might think. + +1. The substitution we generate binds the *template type variables* + which are given to us explicitly. + +2. We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + + That is what the RnEnv2 is for; it does the alpha-renaming + that makes it as if a and b were the same variable. + Initialising the RnEnv2, so that it can generate a fresh + binder when necessary, entails knowing the free variables of + both types. + +3. We must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where x is the template type variable. Then we do not want to + bind x to a/b! This is a kind of occurs check. + The necessary locals accumulate in the RnEnv2. + +Note [tcMatchTy vs tcMatchTyKi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module offers two variants of matching: with kinds and without. +The TyKi variant takes two types, of potentially different kinds, +and matches them. Along the way, it necessarily also matches their +kinds. The Ty variant instead assumes that the kinds are already +eqType and so skips matching up the kinds. + +How do you choose between them? + +1. If you know that the kinds of the two types are eqType, use + the Ty variant. It is more efficient, as it does less work. + +2. If the kinds of variables in the template type might mention type families, + use the Ty variant (and do other work to make sure the kinds + work out). These pure unification functions do a straightforward + syntactic unification and do no complex reasoning about type + families. Note that the types of the variables in instances can indeed + mention type families, so instance lookup must use the Ty variant. + + (Nothing goes terribly wrong -- no panics -- if there might be type + families in kinds in the TyKi variant. You just might get match + failure even though a reducing a type family would lead to success.) + +3. Otherwise, if you're sure that the variable kinds do not mention + type families and you're not already sure that the kind of the template + equals the kind of the target, then use the TyKi version. +-} + +-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) +-- @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might bind coercion variables, +-- if the variable is an argument to a GADT constructor. +-- +-- Precondition: typeKind ty1 `eqType` typeKind ty2 +-- +-- We don't pass in a set of "template variables" to be bound +-- by the match, because tcMatchTy (and similar functions) are +-- always used on top-level types, so we can bind any of the +-- free variables of the LHS. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTy :: Type -> Type -> Maybe TCvSubst +tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] + +tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst + -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM bind_me subst ty1 ty2 + = tc_match_tys_x bind_me False subst [ty1] [ty2] + +-- | Like 'tcMatchTy', but allows the kinds of the types to differ, +-- and thus matches them as well. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKi :: Type -> Type -> Maybe TCvSubst +tcMatchTyKi ty1 ty2 + = tc_match_tys (const BindMe) True [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyX :: TCvSubst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TCvSubst +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTys :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot; in principle the template + -- variables could be free in the target +tcMatchTys tys1 tys2 + = tc_match_tys (const BindMe) False tys1 tys2 + +-- | Like 'tcMatchTyKi' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKis :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKis tys1 tys2 + = tc_match_tys (const BindMe) True tys1 tys2 + +-- | Like 'tcMatchTys', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTysX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTysX subst tys1 tys2 + = tc_match_tys_x (const BindMe) False subst tys1 tys2 + +-- | Like 'tcMatchTyKis', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKisX subst tys1 tys2 + = tc_match_tys_x (const BindMe) True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + +-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' +tc_match_tys_x :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> TCvSubst + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + = case tc_unify_tys bind_me + False -- Matching, not unifying + False -- Not an injectivity check + match_kis + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ TCvSubst in_scope tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyKiX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpl_tvs) False False + True -- <-- this means to match the kinds + rn_env tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +matchBindFun :: TyCoVarSet -> TyVar -> BindFlag +matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem + + +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +-- See Note [Rough match] field in GHC.Core.InstEnv + +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty + | Just (ty', _) <- splitCastTy_maybe ty = rough ty' + | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) + | otherwise = Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: Maybe Name -> Maybe Name -> Bool +itemCantMatch (Just t) (Just a) = t /= a +itemCantMatch _ _ = False + + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +We see here that we want precisely the apartness check implemented within +tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely +apart. Note that since we are simply dropping dead code, a conservative test +suffices. +-} + +-- | Given a list of pairs of types, are any two members of a pair surely +-- apart, even after arbitrary type function evaluation and substitution? +typesCantMatch :: [(Type,Type)] -> Bool +-- See Note [Pruning dead case alternatives] +typesCantMatch prs = any (uncurry cant_match) prs + where + cant_match :: Type -> Type -> Bool + cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of + SurelyApart -> True + _ -> False + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [Fine-grained unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. But, a substitution to +*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. +Why do we care? Consider these two type family instances: + +type instance F x x = Int +type instance F [y] y = Bool + +If we also have + +type instance Looper = [Looper] + +then the instances potentially overlap. The solution is to use unification +over infinite terms. This is possible (see [1] for lots of gory details), but +a full algorithm is a little more power than we need. Instead, we make a +conservative approximation and just omit the occurs check. + +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check +failure ("MaybeApart"), or general failure ("SurelyApart"). + +See also #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Fine-grained unification]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. + +Note [Unification with skolems] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we discover that two types unify if and only if a skolem variable is +substituted, we can't properly unify the types. But, that skolem variable +may later be instantiated with a unifyable type. So, we return maybeApart +in these cases. +-} + +-- | Simple unification of two types; all type variables are bindable +-- Precondition: the kinds are already equal +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe TCvSubst + -- A regular one-shot (idempotent) substitution +tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] + +-- | Like 'tcUnifyTy', but also unifies the kinds +tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst +tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] + +-- | Unify two types, treating type family applications as possibly unifying +-- with anything and looking through injective type family applications. +-- Precondition: kinds are the same +tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> Type -> Type -> Maybe TCvSubst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyWithTFs twoWay t1 t2 + = case tc_unify_tys (const BindMe) twoWay True False + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (subst, _) -> Just $ maybe_fix subst + MaybeApart (subst, _) -> Just $ maybe_fix subst + -- we want to *succeed* in questionable cases. This is a + -- pre-unification algorithm. + SurelyApart -> Nothing + where + in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] + rn_env = mkRnEnv2 in_scope + + maybe_fix | twoWay = niFixTCvSubst + | otherwise = mkTvSubst in_scope -- when matching, don't confuse + -- domain with range + +----------------- +tcUnifyTys :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- | Like 'tcUnifyTys' but also unifies the kinds +tcUnifyTyKis :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst +tcUnifyTyKis bind_fn tys1 tys2 + = case tcUnifyTyKisFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Fine-grained unification] +type UnifyResult = UnifyResultM TCvSubst +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart a -- the subst has as much as we know + -- it must be part of a most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + deriving Functor + +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + + SurelyApart >>= _ = SurelyApart + MaybeApart x >>= f = case f x of + Unifiable y -> MaybeApart y + other -> other + Unifiable x >>= f = f x + +instance Alternative UnifyResultM where + empty = SurelyApart + + a@(Unifiable {}) <|> _ = a + _ <|> b@(Unifiable {}) = b + a@(MaybeApart {}) <|> _ = a + _ <|> b@(MaybeApart {}) = b + SurelyApart <|> SurelyApart = SurelyApart + +instance MonadPlus UnifyResultM + +-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose +-- domain elements all respond 'BindMe' to @bind_tv@) such that +-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned +-- Coercions. This version requires that the kinds of the types are the same, +-- if you unify left-to-right. +tcUnifyTysFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fn tys1 tys2 + = tc_unify_tys_fg False bind_fn tys1 tys2 + +tcUnifyTyKisFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTyKisFG bind_fn tys1 tys2 + = tc_unify_tys_fg True bind_fn tys1 tys2 + +tc_unify_tys_fg :: Bool + -> (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tc_unify_tys_fg match_kis bind_fn tys1 tys2 + = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixTCvSubst env } + where + vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + env = mkRnEnv2 $ mkInScopeSet vars + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: (TyVar -> BindFlag) + -> AmIUnifying -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> Bool -- ^ True <=> treat the kinds as well + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then +-- the kinds of the types should be the same. However, this doesn't work, +-- as the types may be a dependent telescope, where later types have kinds +-- that mention variables occurring earlier in the list of types. Here's an +-- example (from typecheck/should_fail/T12709): +-- template: [rep :: RuntimeRep, a :: TYPE rep] +-- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] +-- We can see that matching the first pair will make the kinds of the second +-- pair equal. Yet, we still don't need a separate pass to unify the kinds +-- of these types, so it's appropriate to use the Ty variant of unification. +-- See also Note [tcMatchTy vs tcMatchTyKi]. +tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 + = initUM tv_env cv_env $ + do { when match_kis $ + unify_tys env kis1 kis2 + ; unify_tys env tys1 tys2 + ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } + where + env = UMEnv { um_bind_fun = bind_fn + , um_skols = emptyVarSet + , um_unif = unif + , um_inj_tf = inj_check + , um_rn_env = rn_env } + + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 + +instance Outputable a => Outputable (UnifyResultM a) where + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart x) = text "MaybeApart" <+> ppr x + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv/CvSubstEnv pair that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is much trickier than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitution to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in #9106. + +It gets worse. In #14164 we wanted to take the fixpoint of +this substitution + [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) + (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) + , a_aY6 :-> a_aXQ ] + +We have to apply the substitution for a_aY6 two levels deep inside +the invocation of F! We don't have a function that recursively +applies substitutions inside the kinds of variable occurrences (and +probably rightly so). + +So, we work as follows: + + 1. Start with the current substitution (which we are + trying to fixpoint + [ xs :-> F a (z :: a) (rest :: G a (z :: a)) + , a :-> b ] + + 2. Take all the free vars of the range of the substitution: + {a, z, rest, b} + NB: the free variable finder closes over + the kinds of variable occurrences + + 3. If none are in the domain of the substitution, stop. + We have found a fixpoint. + + 4. Remove the variables that are bound by the substitution, leaving + {z, rest, b} + + 5. Do a topo-sort to put them in dependency order: + [ b :: *, z :: a, rest :: G a z ] + + 6. Apply the substitution left-to-right to the kinds of these + tyvars, extending it each time with a new binding, so we + finish up with + [ xs :-> ..as before.. + , a :-> b + , b :-> b :: * + , z :-> z :: b + , rest :-> rest :: G b (z :: b) ] + Note that rest now has the right kind + + 7. Apply this extended substitution (once) to the range of + the /original/ substitution. (Note that we do the + extended substitution would go on forever if you tried + to find its fixpoint, because it maps z to z.) + + 8. And go back to step 1 + +In Step 6 we use the free vars from Step 2 as the initial +in-scope set, because all of those variables appear in the +range of the substitution, so they must all be in the in-scope +set. But NB that the type substitution engine does not look up +variables in the in-scope set; it is used only to ensure no +shadowing. +-} + +niFixTCvSubst :: TvSubstEnv -> TCvSubst +-- Find the idempotent fixed point of the non-idempotent substitution +-- This is surprisingly tricky: +-- see Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixTCvSubst tenv + | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) + | otherwise = subst + where + range_fvs :: FV + range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) + -- It's OK to use nonDetEltsUFM here because the + -- order of range_fvs, range_tvs is immaterial + + range_tvs :: [TyVar] + range_tvs = fvVarList range_fvs + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + -- See Note [Finding the substitution fixpoint], Step 6 + init_in_scope = mkInScopeSet (fvVarSet range_fvs) + subst = foldl' add_free_tv + (mkTvSubst init_in_scope tenv) + free_tvs + + add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv subst tv + = extendTvSubst subst tv (mkTyVarTy tv') + where + tv' = updateTyVarKind (substTy subst) tv + +niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet +-- Apply the non-idempotent substitution to a set of type variables, +-- remembering that the substitution isn't necessarily idempotent +-- This is used in the occurs check, before extending the substitution +niSubstTvSet tsubst tvs + = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs + -- It's OK to nonDetFoldUFM here because we immediately forget the + -- ordering by creating a set. + where + get tv + | Just ty <- lookupVarEnv tsubst tv + = niSubstTvSet tsubst (tyCoVarsOfType ty) + + | otherwise + = unitVarSet tv + +{- +************************************************************************ +* * + unify_ty: the main workhorse +* * +************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pure unifier, unify_ty, defined in this module, tries to work out +a substitution to make two types say True to eqType. NB: eqType is +itself not purely syntactic; it accounts for CastTys; +see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + +Unlike the "impure unifiers" in the typechecker (the eager unifier in +TcUnify, and the constraint solver itself in TcCanonical), the pure +unifier It does /not/ work up to ~. + +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. Any reference to "flattening" refers to the flattening +algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not +the flattening algorithm in the solver. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. + If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). + θ is a most general unifier for τ₁ and τ₂. + +(U2) Completeness. + If (unify ξ₁ ξ₂) = SurelyApart, + then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. + If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, + for any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. + If (unify ξ τ♭) = SurelyApart, then there exists no θ + such that θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ + If (unify τ₁♭ τ₂♭) = SurelyApart, + then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even + after arbitrary type family reductions. Note that σ and τ are + not flattened here. + +(I2) If (unify σ τ) = MaybeApart θ, and if some + φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars + in σ are bound in θ. + + Property M1 means that we must extend the substitution with, + say (a ↦ a) when appropriate during matching. + See also Note [Self-substitution when matching]. + +(M2) Completeness of matching. + If θ(σ) = τ, then (match σ τ) = Unifiable φ, + where θ is an extension of φ. + +Sadly, property M2 and I2 conflict. Consider + +type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + +Consider now two matching problems: + +P1. match (F1 a Bool) (F1 Int Bool) +P2. match (F1 a Bool) (F1 Double String) + +In case P1, we must find (a ↦ Int) to satisfy M2. +In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note +that the correct mapping for I2 is (a ↦ Int). There is no way to discover +this, but we mustn't map a to anything else!) + +We thus must parameterize the algorithm over whether it's being used +for an injectivity check (refrain from looking at non-injective arguments +to type families) or not (do indeed look at those arguments). This is +implemented by the uf_inj_tf field of UmEnv. + +(It's all a question of whether or not to include equation (7) from Fig. 2 +of [ITF].) + +This extra parameter is a bit fiddly, perhaps, but seemingly less so than +having two separate, almost-identical algorithms. + +Note [Self-substitution when matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should happen when we're *matching* (not unifying) a1 with a1? We +should get a substitution [a1 |-> a1]. A successful match should map all +the template variables (except ones that disappear when expanding synonyms). +But when unifying, we don't want to do this, because we'll then fall into +a loop. + +This arrangement affects the code in three places: + - If we're matching a refined template variable, don't recur. Instead, just + check for equality. That is, if we know [a |-> Maybe a] and are matching + (a ~? Maybe Int), we want to just fail. + + - Skip the occurs check when matching. This comes up in two places, because + matching against variables is handled separately from matching against + full-on types. + +Note that this arrangement was provoked by a real failure, where the same +unique ended up in the template as in the target. (It was a rule firing when +compiling Data.List.NonEmpty.) + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left and then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion to the match/unify worker. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. Note that we do not unify kinds at the leaves +(as we did previously). We thus have + +INVARIANT: In the call + unify_ty ty1 ty2 kco +it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where +`subst` is the ambient substitution in the UM monad. + +To get this coercion, we first have to match/unify +the kinds before looking at the types. Happily, we need look only one level +up, as all kinds are guaranteed to have kind *. + +When we're working with type applications (either TyConApp or AppTy) we +need to worry about establishing INVARIANT, as the kinds of the function +& arguments aren't (necessarily) included in the kind of the result. +When unifying two TyConApps, this is easy, because the two TyCons are +the same. Their kinds are thus the same. As long as we unify left-to-right, +we'll be sure to unify types' kinds before the types themselves. (For example, +think about Proxy :: forall k. k -> *. Unifying the first args matches up +the kinds of the second args.) + +For AppTy, we must unify the kinds of the functions, but once these are +unified, we can continue unifying arguments without worrying further about +kinds. + +The interface to this module includes both "...Ty" functions and +"...TyKi" functions. The former assume that INVARIANT is already +established, either because the kinds are the same or because the +list of types being passed in are the well-typed arguments to some +type constructor (see two paragraphs above). The latter take a separate +pre-pass over the kinds to establish INVARIANT. Sometimes, it's important +not to take the second pass, as it caused #12442. + +We thought, at one point, that this was all unnecessary: why should +casts be in types in the first place? But they are sometimes. In +dependent/should_compile/KindEqualities2, we see, for example the +constraint Num (Int |> (blah ; sym blah)). We naturally want to find +a dictionary for that constraint, which requires dealing with +coercions in this manner. + +Note [Matching in the presence of casts (1)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching, it is crucial that no variables from the template +end up in the range of the matching substitution (obviously!). +When unifying, that's not a constraint; instead we take the fixpoint +of the substitution at the end. + +So what should we do with this, when matching? + unify_ty (tmpl |> co) tgt kco + +Previously, wrongly, we pushed 'co' in the (horrid) accumulating +'kco' argument like this: + unify_ty (tmpl |> co) tgt kco + = unify_ty tmpl tgt (kco ; co) + +But that is obviously wrong because 'co' (from the template) ends +up in 'kco', which in turn ends up in the range of the substitution. + +This all came up in #13910. Because we match tycon arguments +left-to-right, the ambient substitution will already have a matching +substitution for any kinds; so there is an easy fix: just apply +the substitution-so-far to the coercion from the LHS. + +Note that + +* When matching, the first arg of unify_ty is always the template; + we never swap round. + +* The above argument is distressingly indirect. We seek a + better way. + +* One better way is to ensure that type patterns (the template + in the matching process) have no casts. See #14119. + +Note [Matching in the presence of casts (2)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) +and we are matching + tcMatchTy (T k (a::k)) (T j (b::j)) + +Then we'll match k :-> j, as expected. But then in unify_tys +we invoke + unify_tys env (a::k) (b::j) (Refl j) + +Although we have unified k and j, it's very important that we put +(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. +If we put (Refl k) we'd end up with the substitution + a :-> b |> Refl k +which is bogus because one of the template variables, k, +appears in the range of the substitution. Eek. + +Similar care is needed in unify_ty_app. + + +Note [Polykinded tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: forall k. Type -> K +and we are unifying + ty1: T @Type Int :: Type + ty2: T @(Type->Type) Int Int :: Type + +These two TyConApps have the same TyCon at the front but they +(legitimately) have different numbers of arguments. They +are surelyApart, so we can report that without looking any +further (see #15704). +-} + +-------------- unify_ty: the main workhorse ----------- + +type AmIUnifying = Bool -- True <=> Unifying + -- False <=> Matching + +unify_ty :: UMEnv + -> Type -> Type -- Types to be unified and a co + -> CoercionN -- A coercion between their kinds + -- See Note [Kind coercions in Unify] + -> UM () +-- See Note [Specification of unification] +-- Respects newtypes, PredTypes + +unify_ty env ty1 ty2 kco + -- TODO: More commentary needed here + | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco + | CastTy ty1' co <- ty1 = if um_unif env + then unify_ty env ty1' ty2 (co `mkTransCo` kco) + else -- See Note [Matching in the presence of casts (1)] + do { subst <- getSubst env + ; let co' = substCo subst co + ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } + | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) + +unify_ty env (TyVarTy tv1) ty2 kco + = uVar env tv1 ty2 kco +unify_ty env ty1 (TyVarTy tv2) kco + | um_unif env -- If unifying, can swap args + = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) + +unify_ty env ty1 ty2 _kco + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) + = if isInjectiveTyCon tc1 Nominal + then unify_tys env tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + ; unify_tys env inj_tys1 inj_tys2 + ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] + don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } + + | Just (tc1, _) <- mb_tc_app1 + , not (isGenerativeTyCon tc1 Nominal) + -- E.g. unify_ty (F ty1) b = MaybeApart + -- because the (F ty1) behaves like a variable + -- NB: if unifying, we have already dealt + -- with the 'ty2 = variable' case + = maybeApart + + | Just (tc2, _) <- mb_tc_app2 + , not (isGenerativeTyCon tc2 Nominal) + , um_unif env + -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) + -- because the (F ty2) behaves like a variable + -- NB: we have already dealt with the 'ty1 = variable' case + = maybeApart + + where + mb_tc_app1 = tcSplitTyConApp_maybe ty1 + mb_tc_app2 = tcSplitTyConApp_maybe ty2 + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp, so use splitAppTy_maybe + -- NB: we've already dealt with type variables, + -- so if one type is an App the other one jolly well better be too +unify_ty env (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty env ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) + ; let env' = umRnBndr2 env tv1 tv2 + ; unify_ty env' ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty env (CoercionTy co1) (CoercionTy co2) kco + = do { c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not (um_unif env) + , not (cv `elemVarEnv` c_subst) + , BindMe <- tvBindFlag env cv + -> do { checkRnEnv env (tyCoVarsOfCo co2) + ; let (co_l, co_r) = decomposeFunCo Nominal kco + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + ; extendCvEnv cv (co_l `mkTransCo` + co2 `mkTransCo` + mkSymCo co_r) } + _ -> return () } + +unify_ty _ _ _ _ = surelyApart + +unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () +unify_ty_app env ty1 ty1args ty2 ty2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 + = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) + + | otherwise + = do { let ki1 = typeKind ty1 + ki2 = typeKind ty2 + -- See Note [Kind coercions in Unify] + ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) + ; unify_ty env ty1 ty2 (mkNomReflCo ki2) + -- Very important: 'ki2' not 'ki1' + -- See Note [Matching in the presence of casts (2)] + ; unify_tys env ty1args ty2args } + +unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +unify_tys env orig_xs orig_ys + = go orig_xs orig_ys + where + go [] [] = return () + go (x:xs) (y:ys) + -- See Note [Kind coercions in Unify] + = do { unify_ty env x y (mkNomReflCo $ typeKind y) + -- Very important: 'y' not 'x' + -- See Note [Matching in the presence of casts (2)] + ; go xs ys } + go _ _ = surelyApart + -- Possibly different saturations of a polykinded tycon + -- See Note [Polykinded tycon applications] + +--------------------------------- +uVar :: UMEnv + -> InTyVar -- Variable to be unified + -> Type -- with this Type + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +uVar env tv1 ty kco + = do { -- Apply the ambient renaming + let tv1' = umRnOccL env tv1 + + -- Check to see whether tv1 is refined by the substitution + ; subst <- getTvSubstEnv + ; case (lookupVarEnv subst tv1') of + Just ty' | um_unif env -- Unifying, so call + -> unify_ty env ty' ty kco -- back into unify + | otherwise + -> -- Matching, we don't want to just recur here. + -- this is because the range of the subst is the target + -- type, not the template type. So, just check for + -- normal type equality. + guard ((ty' `mkCastTy` kco) `eqType` ty) + Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue + +uUnrefined :: UMEnv + -> OutTyVar -- variable to be unified + -> Type -- with this Type + -> Type -- (version w/ expanded synonyms) + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +-- We know that tv1 isn't refined + +uUnrefined env tv1' ty2 ty2' kco + | Just ty2'' <- coreView ty2' + = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms + -- This is essential, in case we have + -- type Foo a = a + -- and then unify a ~ Foo a + + | TyVarTy tv2 <- ty2' + = do { let tv2' = umRnOccR env tv2 + ; unless (tv1' == tv2' && um_unif env) $ do + -- If we are unifying a ~ a, just return immediately + -- Do not extend the substitution + -- See Note [Self-substitution when matching] + + -- Check to see whether tv2 is refined + { subst <- getTvSubstEnv + ; case lookupVarEnv subst tv2 of + { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco + ; _ -> + + do { -- So both are unrefined + -- Bind one or the other, depending on which is bindable + ; let b1 = tvBindFlag env tv1' + b2 = tvBindFlag env tv2' + ty1 = mkTyVarTy tv1' + ; case (b1, b2) of + (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + (_, BindMe) | um_unif env + -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) + + _ | tv1' == tv2' -> return () + -- How could this happen? If we're only matching and if + -- we're comparing forall-bound variables. + + _ -> maybeApart -- See Note [Unification with skolems] + }}}} + +uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable + = case tvBindFlag env tv1' of + Skolem -> maybeApart -- See Note [Unification with skolems] + BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + +bindTv :: UMEnv -> OutTyVar -> Type -> UM () +-- OK, so we want to extend the substitution with tv := ty +-- But first, we must do a couple of checks +bindTv env tv1 ty2 + = do { let free_tvs2 = tyCoVarsOfType ty2 + + -- Make sure tys mentions no local variables + -- E.g. (forall a. b) ~ (forall a. [a]) + -- We should not unify b := [a]! + ; checkRnEnv env free_tvs2 + + -- Occurs check, see Note [Fine-grained unification] + -- Make sure you include 'kco' (which ty2 does) #14846 + ; occurs <- occursCheck env tv1 free_tvs2 + + ; if occurs then maybeApart + else extendTvEnv tv1 ty2 } + +occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool +occursCheck env tv free_tvs + | um_unif env + = do { tsubst <- getTvSubstEnv + ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } + + | otherwise -- Matching; no occurs check + = return False -- See Note [Self-substitution when matching] + +{- +%************************************************************************ +%* * + Binding decisions +* * +************************************************************************ +-} + +data BindFlag + = BindMe -- A regular type variable + + | Skolem -- This type variable is a skolem constant + -- Don't bind it; it only matches itself + deriving Eq + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +data UMEnv + = UMEnv { um_unif :: AmIUnifying + + , um_inj_tf :: Bool + -- Checking for injectivity? + -- See (end of) Note [Specification of unification] + + , um_rn_env :: RnEnv2 + -- Renaming InTyVars to OutTyVars; this eliminates + -- shadowing, and lines up matching foralls on the left + -- and right + + , um_skols :: TyVarSet + -- OutTyVars bound by a forall in this unification; + -- Do not bind these in the substitution! + -- See the function tvBindFlag + + , um_bind_fun :: TyVar -> BindFlag + -- User-supplied BindFlag function, + -- for variables not in um_skols + } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv } + +newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } + deriving (Functor) + +instance Applicative UM where + pure a = UM (\s -> pure (s, a)) + (<*>) = ap + +instance Monad UM where + m >>= k = UM (\state -> + do { (state', v) <- unUM m state + ; unUM (k v) state' }) + +-- need this instance because of a use of 'guard' above +instance Alternative UM where + empty = UM (\_ -> Control.Applicative.empty) + m1 <|> m2 = UM (\state -> + unUM m1 state <|> + unUM m2 state) + +instance MonadPlus UM + +instance MonadFail UM where + fail _ = UM (\_ -> SurelyApart) -- failed pattern match + +initUM :: TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM a -> UnifyResultM a +initUM subst_env cv_subst_env um + = case unUM um state of + Unifiable (_, subst) -> Unifiable subst + MaybeApart (_, subst) -> MaybeApart subst + SurelyApart -> SurelyApart + where + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env } + +tvBindFlag :: UMEnv -> OutTyVar -> BindFlag +tvBindFlag env tv + | tv `elemVarSet` um_skols env = Skolem + | otherwise = um_bind_fun env tv + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) + +getSubst :: UMEnv -> UM TCvSubst +getSubst env = do { tv_env <- getTvSubstEnv + ; cv_env <- getCvSubstEnv + ; let in_scope = rnInScopeSet (um_rn_env env) + ; return (mkTCvSubst in_scope (tv_env, cv_env)) } + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv +umRnBndr2 env v1 v2 + = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } + where + (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 + +checkRnEnv :: UMEnv -> VarSet -> UM () +checkRnEnv env varset + | isEmptyVarSet skol_vars = return () + | varset `disjointVarSet` skol_vars = return () + | otherwise = maybeApart + -- ToDo: why MaybeApart? + -- I think SurelyApart would be right + where + skol_vars = um_skols env + -- NB: That isEmptyVarSet guard is a critical optimization; + -- it means we don't have to calculate the free vars of + -- the type, often saving quite a bit of allocation. + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: UM () -> UM () +don'tBeSoSure um = UM $ \ state -> + case unUM um state of + SurelyApart -> MaybeApart (state, ()) + other -> other + +umRnOccL :: UMEnv -> TyVar -> TyVar +umRnOccL env v = rnOccL (um_rn_env env) v + +umRnOccR :: UMEnv -> TyVar -> TyVar +umRnOccR env v = rnOccR (um_rn_env env) v + +umSwapRn :: UMEnv -> UMEnv +umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } + +maybeApart :: UM () +maybeApart = UM (\state -> MaybeApart (state, ())) + +surelyApart :: UM a +surelyApart = UM (\_ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +data MatchEnv = ME { me_tmpls :: TyVarSet + , me_env :: RnEnv2 } + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, +-- where @==@ there means that the result of 'liftCoSubst' has the same +-- type as the original co; but may be different under the hood. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co, coercion to match against + -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co + -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co + -> Maybe LiftCoEnv +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = allVarSet (not . f) + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + -- See Note [Matching in the presence of casts (1)] + = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' + substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' + in + ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) + (substed_co_r `mkTransCo` rkco) + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco + = ty_co_match_tc menv subst tc1 tys tc2 cos +ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco + -- Despite the fact that (->) is polymorphic in four type variables (two + -- runtime rep and two types), we shouldn't need to explicitly unify the + -- runtime reps here; unifying the types themselves should be sufficient. + -- See Note [Representation of function types]. + | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co + , tc == funTyCon + = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] + in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos + +ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) + (ForAllCo tv2 kind_co2 co2) + lkco rkco + | isTyVar tv1 && isTyVar tv2 + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco + = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) + +ty_co_match menv subst ty co1 lkco rkco + | Just (CastTy t co, r) <- isReflCo_maybe co1 + -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us + -- t |> co ~ t ; ; t ~ t |> co + -- But transitive coercions are not helpful. Therefore we deal + -- with it here: we do recursion on the smaller reflexive coercion, + -- while propagating the correct kind coercions. + = let kco' = mkSymCo co + in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') + (rkco `mkTransCo` kco') + + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } + where + Pair lkcos rkcos + = traverse (fmap mkNomReflCo . coercionKind) cos2 + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> [Type] -> Coercion -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1 ty1args co2 co2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (co2', co2a) <- splitAppCo_maybe co2 + = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) + + | otherwise + = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 + ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco + ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args + ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } + where + ki1 = typeKind ty1 + ki2 = promoteCoercion co2 + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] + -> [Coercion] -> [Coercion] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args _ subst [] [] _ _ = Just subst +ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) + = do { subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args lkcos rkcos } +ty_co_match_args _ _ _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl co = + case (isReflCo_maybe co) of + Just (AppTy ty1 ty2, Nominal) + -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) + Just (FunTy _ ty1 ty2, r) + | Just rep1 <- getRuntimeRep_maybe ty1 + , Just rep2 <- getRuntimeRep_maybe ty2 + -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 + , mkReflCo r ty1, mkReflCo r ty2 ]) + Just (TyConApp tc tys, r) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) + Just (ForAllTy (Bndr tv _) ty, r) + -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) + -- NB: NoRefl variant. Otherwise, we get a loop! + _ -> Nothing diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -27,7 +27,7 @@ getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, - exprIsBig, exprIsConLike, + exprIsConLike, isCheapApp, isExpandableApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, @@ -63,35 +63,35 @@ #include "HsVersions.h" import GhcPrelude +import GHC.Platform import GHC.Core import PrelNames ( makeStaticName ) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars ) -import Var -import SrcLoc -import VarEnv -import VarSet -import Name -import Literal -import DataCon +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Core.DataCon import PrimOp -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import PrelNames( absentErrorIdKey ) -import Type -import Predicate -import TyCoRep( TyCoBinder(..), TyBinder ) -import Coercion -import TyCon -import Unique +import GHC.Core.Type as Type +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Types.Unique import Outputable import TysPrim -import GHC.Driver.Session import FastString import Maybes import ListSetOps ( minusList ) -import BasicTypes ( Arity, isConLike ) +import GHC.Types.Basic ( Arity, isConLike ) import Util import Pair import Data.ByteString ( ByteString ) @@ -100,7 +100,7 @@ import Data.Ord ( comparing ) import OrdList import qualified Data.Set as Set -import UniqSet +import GHC.Types.Unique.Set {- ************************************************************************ @@ -162,7 +162,7 @@ go e@(Cast {}) = check_type e go (Tick _ e) = go e go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) - go (Coercion {}) = False -- this case can happen in SetLevels + go (Coercion {}) = False -- this case can happen in GHC.Core.Op.SetLevels check_type = isTypeLevPoly . exprType -- slow approach @@ -625,7 +625,7 @@ we generate (error "Inaccessible alternative"). Similar things can happen (augmented by GADTs) when the Simplifier -filters down the matching alternatives in Simplify.rebuildCase. +filters down the matching alternatives in GHC.Core.Op.Simplify.rebuildCase. -} --------------------------------- @@ -817,9 +817,9 @@ C2 -> e0 ``` -It isn't obvious that refineDefaultAlt does this but if you look at its one -call site in SimplUtils then the `imposs_deflt_cons` argument is populated with -constructors which are matched elsewhere. +It isn't obvious that refineDefaultAlt does this but if you look at its one call +site in GHC.Core.Op.Simplify.Utils then the `imposs_deflt_cons` argument is +populated with constructors which are matched elsewhere. -} @@ -864,11 +864,29 @@ and similarly in cascade for all the join points! -NB: it's important that all this is done in [InAlt], *before* we work -on the alternatives themselves, because Simplify.simplAlt may zap the -occurrence info on the binders in the alternatives, which in turn -defeats combineIdenticalAlts (see #7360). +Note [Combine identical alternatives: wrinkles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* It's important that we try to combine alternatives *before* + simplifying them, rather than after. Reason: because + Simplify.simplAlt may zap the occurrence info on the binders in the + alternatives, which in turn defeats combineIdenticalAlts use of + isDeadBinder (see #7360). + + You can see this in the call to combineIdenticalAlts in + GHC.Core.Op.Simplify.Utils.prepareAlts. Here the alternatives have type InAlt + (the "In" meaning input) rather than OutAlt. + +* combineIdenticalAlts does not work well for nullary constructors + case x of y + [] -> f [] + (_:_) -> f y + Here we won't see that [] and y are the same. Sigh! This problem + is solved in CSE, in GHC.Core.Op.CSE.combineAlts, which does a better version + of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have + here. + See Note [Combine case alts: awkward corner] in GHC.Core.Op.CSE). + Note [Care with impossible-constructors when combining alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have (#10538) @@ -1120,8 +1138,8 @@ 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 @@ -1131,7 +1149,7 @@ 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 @@ -1314,7 +1332,7 @@ * True of constructor applications (K a b) -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes. +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. (NB: exprIsCheap might not be true of this) * False of case-expressions. If we have @@ -1658,10 +1676,10 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprOkForSpeculation accepts very special case expressions. Reason: (a ==# b) is ok-for-speculation, but the litEq rules -in PrelRules convert it (a ==# 3#) to +in GHC.Core.Op.ConstantFold convert it (a ==# 3#) to case a of { DEFAULT -> 0#; 3# -> 1# } for excellent reasons described in - PrelRules Note [The litEq rule: converting equality to case]. + GHC.Core.Op.ConstantFold Note [The litEq rule: converting equality to case]. So, annoyingly, we want that case expression to be ok-for-speculation too. Bother. @@ -1675,12 +1693,12 @@ Does the RHS of v satisfy the let/app invariant? Previously we said yes, on the grounds that y is evaluated. But the binder-swap done - by SetLevels would transform the inner alternative to + by GHC.Core.Op.SetLevels would transform the inner alternative to DEFAULT -> ... (let v::Int# = case x of { ... } in ...) .... which does /not/ satisfy the let/app invariant, because x is not evaluated. See Note [Binder-swap during float-out] - in SetLevels. To avoid this awkwardness it seems simpler + in GHC.Core.Op.SetLevels. To avoid this awkwardness it seems simpler to stick to unlifted scrutinees where the issue does not arise. @@ -1701,7 +1719,7 @@ ----- Historical note: #15696: -------- - Previously SetLevels used exprOkForSpeculation to guide + Previously GHC.Core.Op.SetLevels used exprOkForSpeculation to guide floating of single-alternative cases; it now uses exprIsHNF Note [Floating single-alternative cases]. @@ -1711,8 +1729,8 @@ A -> ... _ -> ...(case (case x of { B -> p; C -> p }) of I# r -> blah)... - If SetLevels considers the inner nested case as - ok-for-speculation it can do case-floating (in SetLevels). + If GHC.Core.Op.SetLevels considers the inner nested case as + ok-for-speculation it can do case-floating (in GHC.Core.Op.SetLevels). So we'd float to: case e of x { DEAFULT -> case (case x of { B -> p; C -> p }) of I# r -> @@ -2046,7 +2064,7 @@ case in the RHS of the binding for 'v' is fine. But only if we *know* that 'y' is evaluated. -c.f. add_evals in Simplify.simplAlt +c.f. add_evals in GHC.Core.Op.Simplify.simplAlt ************************************************************************ * * @@ -2058,45 +2076,30 @@ -- | A cheap equality test which bales out fast! -- If it returns @True@ the arguments are definitely equal, -- otherwise, they may or may not be equal. --- --- See also 'exprIsBig' cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr = cheapEqExpr' (const False) -- | Cheap expression equality test, can ignore ticks by type. cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool -cheapEqExpr' ignoreTick = go_s - where go_s = go `on` stripTicksTopE ignoreTick - go (Var v1) (Var v2) = v1 == v2 - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = t1 `eqType` t2 - go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 +{-# INLINE cheapEqExpr' #-} +cheapEqExpr' ignoreTick e1 e2 + = go e1 e2 + where + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 + go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 + go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2 - go (App f1 a1) (App f2 a2) - = f1 `go_s` f2 && a1 `go_s` a2 + go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 + go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 + go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 - go (Cast e1 t1) (Cast e2 t2) - = e1 `go_s` e2 && t1 `eqCoercion` t2 + go _ _ = False - go (Tick t1 e1) (Tick t2 e2) - = t1 == t2 && e1 `go_s` e2 - go _ _ = False - {-# INLINE go #-} -{-# INLINE cheapEqExpr' #-} -exprIsBig :: Expr b -> Bool --- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' -exprIsBig (Lit _) = False -exprIsBig (Var _) = False -exprIsBig (Type _) = False -exprIsBig (Coercion _) = False -exprIsBig (Lam _ e) = exprIsBig e -exprIsBig (App f a) = exprIsBig f || exprIsBig a -exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! -exprIsBig (Tick _ e) = exprIsBig e -exprIsBig _ = True - eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool -- Compares for equality, modulo alpha eqExpr in_scope e1 e2 @@ -2322,7 +2325,7 @@ says f=bottom, and replaces the (f `seq` True) with just (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not termninate after all. + the definition again, so that it does not terminate after all. Result: seg-fault because the boolean case actually gets a function value. See #1947. @@ -2330,7 +2333,7 @@ * Note [Arity care]: we need to be careful if we just look at f's arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in SimplEnv) so we must *not* trust the + Note [Arity robustness] in GHC.Core.Op.Simplify.Env) so we must *not* trust the arity when checking that 'f' is a value. Otherwise we will eta-reduce f = \x. f x diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -48,30 +48,30 @@ import GhcPrelude import GHC.Iface.Syntax -import DataCon -import Id -import IdInfo +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import TysWiredIn ( heqTyCon ) -import MkId ( noinlineIdName ) +import GHC.Types.Id.Make ( noinlineIdName ) import PrelNames -import Name -import BasicTypes -import Type -import PatSyn +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Core.Type +import GHC.Core.PatSyn import Outputable import FastString import Util -import Var -import VarEnv -import VarSet -import TyCoRep -import TyCoTidy ( tidyCo ) -import Demand ( isTopSig ) -import Cpr ( topCprSig ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy ( tidyCo ) +import GHC.Types.Demand ( isTopSig ) +import GHC.Types.Cpr ( topCprSig ) import Data.Maybe ( catMaybes ) @@ -345,12 +345,12 @@ VisArg -> Required InvisArg -> Inferred -- It's rare for a kind to have a constraint argument, but - -- it can happen. See Note [AnonTCB InvisArg] in TyCon. + -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon. go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) = go (zapTCvSubst env) (substTy env ty) ts - -- See Note [Care with kind instantiation] in Type.hs + -- See Note [Care with kind instantiation] in GHC.Core.Type | otherwise = -- There's a kind error in the type we are trying to print diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -1,14 +1,14 @@ module GHC.CoreToIface where -import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) -import Var ( TyCoVarBinder ) -import VarEnv ( TidyEnv ) -import TyCon ( TyCon ) -import VarSet( VarSet ) +import GHC.Types.Var ( TyCoVarBinder ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Types.Var.Set( VarSet ) --- For TyCoRep +-- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -20,9 +20,9 @@ import GHC.Driver.Phases import GHC.Hs -import SrcLoc +import GHC.Types.SrcLoc import Outputable -import Module +import GHC.Types.Module import UnitInfo {- diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -32,7 +32,7 @@ import Outputable import Panic import Bag -import SrcLoc +import GHC.Types.SrcLoc import Json import Data.Function diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Flags.hs @@ -0,0 +1,524 @@ +module GHC.Driver.Flags + ( DumpFlag(..) + , GeneralFlag(..) + , WarningFlag(..) + , WarnReason (..) + , Language(..) + , optimisationFlags + ) +where + +import GhcPrelude +import Outputable +import EnumSet +import Json + +-- | Debugging flags +data DumpFlag +-- See Note [Updating flag description in the User's Guide] + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_from_stg + | Opt_D_dump_cmm_raw + | Opt_D_dump_cmm_verbose_by_proc + -- All of the cmm subflags (there are a lot!) automatically + -- enabled if you run -ddump-cmm-verbose-by-proc + -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_verbose + -- same as -ddump-cmm-verbose-by-proc but writes each stage + -- to a separate file (if used with -ddump-to-file) + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_switch + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_caf + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + -- end cmm subflags + | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | Opt_D_dump_core_stats + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_ds_preopt + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_parsed_ast + | Opt_D_dump_rn + | Opt_D_dump_rn_ast + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg -- CoreToStg output + | Opt_D_dump_stg_unarised -- STG after unarise + | Opt_D_dump_stg_final -- STG after stg2stg + | Opt_D_dump_call_arity + | Opt_D_dump_exitify + | Opt_D_dump_stranal + | Opt_D_dump_str_signatures + | Opt_D_dump_cpranal + | Opt_D_dump_cpr_signatures + | Opt_D_dump_tc + | Opt_D_dump_tc_ast + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker + | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map + | Opt_D_dump_timings + | Opt_D_dump_view_pattern_commoning + | Opt_D_verbose_core2core + | Opt_D_dump_debug + | Opt_D_dump_json + | Opt_D_ppr_debug + | Opt_D_no_debug_output + deriving (Eq, Show, Enum) + +-- | Enumerates the simple on-or-off dynamic flags +data GeneralFlag +-- See Note [Updating flag description in the User's Guide] + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_D_faststring_stats + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag + | Opt_NoTypeableBinds + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_ShowWarnGroups -- Show the group a warning belongs to + | Opt_HideSourcePaths -- Hide module source/object paths + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintExplicitRuntimeReps + | Opt_PrintEqualityRelations + | Opt_PrintAxiomIncomps + | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms + | Opt_PrintPotentialInstances + | Opt_PrintTypecheckerElaboration + + -- optimisation opts + | Opt_CallArity + | Opt_Exitification + | Opt_Strictness + | Opt_LateDmdAnal -- #6087 + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_LateSpecialise + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_CrossModuleSpecialise + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_StgCSE + | Opt_StgLiftLams + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_SpecConstrKeen + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_CaseFolding -- Constant folding through case-expressions + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infrastructure for improving AA (hidden flag) + | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) + | Opt_IrrefutableTuples + | Opt_CmmSink + | Opt_CmmElimCommonBlocks + | Opt_AsmShortcutting + | Opt_OmitYields + | Opt_FunToThunk -- allow GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs to remove all value lambdas + | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | Opt_CprAnal + | Opt_WorkerWrapper + | Opt_SolveConstantDicts + | Opt_AlignmentSanitisation + | Opt_CatchBottoms + | Opt_NumConstantFolding + + -- PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining + + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code + | Opt_WriteHie -- generate .hie files + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_NoHsMain + | Opt_SplitSections + | Opt_StgStats + | Opt_HideAllPackages + | Opt_HideAllPluginPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_GhciHistory + | Opt_GhciLeakCheck + | Opt_ValidateHie + | Opt_LocalGhciHistory + | Opt_NoIt + | Opt_HelpfulErrors + | Opt_DeferTypeErrors + | Opt_DeferTypedHoles + | Opt_DeferOutOfScopeVariables + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs + | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_Hpc + | Opt_FlatCache + | Opt_ExternalInterpreter + | Opt_OptimalApplicativeDo + | Opt_VersionMacros + | Opt_WholeArchiveHsLibs + -- copy all libs into a single folder prior to linking binaries + -- this should elivate the excessive command line limit restrictions + -- on windows, by only requiring a single -L argument instead of + -- one for each dependency. At the time of this writing, gcc + -- forwards all -L flags to the collect2 command without using a + -- response file and as such breaking apart. + | Opt_SingleLibFolder + | Opt_KeepCAFs + | Opt_KeepGoing + | Opt_ByteCode + + -- output style opts + | Opt_ErrorSpans -- Include full span info in error messages, + -- instead of just the start position. + | Opt_DeferDiagnostics + | Opt_DiagnosticsShowCaret -- Show snippets of offending code + | Opt_PprCaseAsLet + | Opt_PprShowTicks + | Opt_ShowHoleConstraints + -- Options relating to the display of valid hole fits + -- when generating an error message for a typed hole + -- See Note [Valid hole fits include] in TcHoleErrors.hs + | Opt_ShowValidHoleFits + | Opt_SortValidHoleFits + | Opt_SortBySizeHoleFits + | Opt_SortBySubsumHoleFits + | Opt_AbstractRefHoleFits + | Opt_UnclutterValidHoleFits + | Opt_ShowTypeAppOfHoleFits + | Opt_ShowTypeAppVarsOfHoleFits + | Opt_ShowDocsOfHoleFits + | Opt_ShowTypeOfHoleFits + | Opt_ShowProvOfHoleFits + | Opt_ShowMatchesOfHoleFits + + | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] + + -- Suppress all coercions, them replacing with '...' + | Opt_SuppressCoercions + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressUnfoldings + -- Suppress the details of even stable unfoldings + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + | Opt_SuppressStgExts + | Opt_SuppressTicks -- Replaces Opt_PprShowTicks + | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps + + -- temporary flags + | Opt_AutoLinkPackages + | Opt_ImplicitImportQualified + + -- keeping stuff + | Opt_KeepHscppFiles + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + | Opt_KeepHiFiles + | Opt_KeepOFiles + + | Opt_BuildDynamicToo + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + | Opt_PluginTrustworthy + + | Opt_G_NoStateHack + | Opt_G_NoOptCoercion + deriving (Eq, Show, Enum) + +-- Check whether a flag should be considered an "optimisation flag" +-- for purposes of recompilation avoidance (see +-- Note [Ignoring some flag changes] in FlagChecker). Being listed here is +-- not a guarantee that the flag has no other effect. We could, and +-- perhaps should, separate out the flags that have some minor impact on +-- program semantics and/or error behavior (e.g., assertions), but +-- then we'd need to go to extra trouble (and an additional flag) +-- to allow users to ignore the optimisation level even though that +-- means ignoring some change. +optimisationFlags :: EnumSet GeneralFlag +optimisationFlags = EnumSet.fromList + [ Opt_CallArity + , Opt_Strictness + , Opt_LateDmdAnal + , Opt_KillAbsence + , Opt_KillOneShot + , Opt_FullLaziness + , Opt_FloatIn + , Opt_LateSpecialise + , Opt_Specialise + , Opt_SpecialiseAggressively + , Opt_CrossModuleSpecialise + , Opt_StaticArgumentTransformation + , Opt_CSE + , Opt_StgCSE + , Opt_StgLiftLams + , Opt_LiberateCase + , Opt_SpecConstr + , Opt_SpecConstrKeen + , Opt_DoLambdaEtaExpansion + , Opt_IgnoreAsserts + , Opt_DoEtaReduction + , Opt_CaseMerge + , Opt_CaseFolding + , Opt_UnboxStrictFields + , Opt_UnboxSmallStrictFields + , Opt_DictsCheap + , Opt_EnableRewriteRules + , Opt_RegsGraph + , Opt_RegsIterative + , Opt_PedanticBottoms + , Opt_LlvmTBAA + , Opt_LlvmFillUndefWithGarbage + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_OmitYields + , Opt_FunToThunk + , Opt_DictsStrict + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CfgBlocklayout + , Opt_WeightlessBlocklayout + , Opt_CprAnal + , Opt_WorkerWrapper + , Opt_SolveConstantDicts + , Opt_CatchBottoms + , Opt_IgnoreAsserts + ] + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnRedundantConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSignatures + | Opt_WarnMissingLocalSignatures + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedTopBinds + | Opt_WarnUnusedLocalBinds + | Opt_WarnUnusedPatternBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnUnusedTypePatterns + | Opt_WarnUnusedForalls + | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantRecordWildcards + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8 + | Opt_WarnSemigroup -- since 8.0 + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnMissedSpecs + | Opt_WarnAllMissedSpecs + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnMissedExtraSharedLib + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSignatures + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + | Opt_WarnDeferredTypeErrors + | Opt_WarnDeferredOutOfScopeVariables + | Opt_WarnNonCanonicalMonadInstances -- since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- since 8.0 + | Opt_WarnSimplifiableClassConstraints -- Since 8.2 + | Opt_WarnCPPUndef -- Since 8.2 + | Opt_WarnUnbangedStrictPatterns -- Since 8.2 + | Opt_WarnMissingHomeModules -- Since 8.2 + | Opt_WarnPartialFields -- Since 8.4 + | Opt_WarnMissingExportList + | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- Since 8.6 + | Opt_WarnStarBinder -- Since 8.6 + | Opt_WarnImplicitKindVars -- Since 8.6 + | Opt_WarnSpaceAfterBang + | Opt_WarnMissingDerivingStrategies -- Since 8.8 + | Opt_WarnPrepositiveQualifiedModule -- Since TBD + | Opt_WarnUnusedPackages -- Since 8.10 + | Opt_WarnInferredSafeImports -- Since 8.10 + | Opt_WarnMissingSafeHaskellMode -- Since 8.10 + | Opt_WarnCompatUnqualifiedImports -- Since 8.10 + | Opt_WarnDerivingDefaults + deriving (Eq, Show, Enum) + +-- | Used when outputting warnings: if a reason is given, it is +-- displayed. If a warning isn't controlled by a flag, this is made +-- explicit at the point of use. +data WarnReason + = NoReason + -- | Warning was enabled with the flag + | Reason !WarningFlag + -- | Warning was made an error because of -Werror or -Werror=WarningFlag + | ErrReason !(Maybe WarningFlag) + deriving Show + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json (Reason wf) = JSString (show wf) + json (ErrReason Nothing) = JSString "Opt_WarnIsError" + json (ErrReason (Just wf)) = JSString (show wf) + + +data Language = Haskell98 | Haskell2010 + deriving (Eq, Enum, Show) + +instance Outputable Language where + ppr = text . show + diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -39,18 +39,18 @@ import OrdList import TcRnTypes import Bag -import RdrName -import Name -import Id +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Id import GHC.Core import GHCi.RemoteTypes -import SrcLoc -import Type +import GHC.Types.SrcLoc +import GHC.Core.Type import System.Process -import BasicTypes -import Module -import TyCon -import CostCentre +import GHC.Types.Basic +import GHC.Types.Module +import GHC.Core.TyCon +import GHC.Types.CostCentre import GHC.Stg.Syntax import Stream import GHC.Cmm diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -47,6 +47,7 @@ getPackageFrameworkPath, getPackageFrameworks, getUnitInfoMap, + getPackageState, getPreloadPackagesAnd, collectArchives, @@ -54,13 +55,15 @@ packageHsLibs, getLibs, -- * Utils + mkComponentId, + updateComponentId, unwireUnitId, pprFlag, pprPackages, pprPackagesSimple, pprModuleMap, isIndefinite, - isDllName + isDynLinkName ) where @@ -71,11 +74,12 @@ import GHC.PackageDb import UnitInfo import GHC.Driver.Session -import Name ( Name, nameModule_maybe ) -import UniqFM -import UniqDFM -import UniqSet -import Module +import GHC.Driver.Ways +import GHC.Types.Name ( Name, nameModule_maybe ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Module import Util import Panic import GHC.Platform @@ -407,21 +411,21 @@ -- | Find the indefinite package for a given 'ComponentId'. -- The way this works is just by fiat'ing that every indefinite package's -- unit key is precisely its component ID; and that they share uniques. -lookupComponentId :: DynFlags -> ComponentId -> Maybe UnitInfo -lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs +lookupComponentId :: PackageState -> ComponentId -> Maybe UnitInfo +lookupComponentId pkgstate (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs where - UnitInfoMap pkg_map = unitInfoMap (pkgState dflags) + UnitInfoMap pkg_map = unitInfoMap pkgstate -} -- | Find the package we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this) -lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId -lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) +lookupPackageName :: PackageState -> PackageName -> Maybe ComponentId +lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate) -- | Search for packages with a given package ID (e.g. \"foo-0.1\") -searchPackageId :: DynFlags -> SourcePackageId -> [UnitInfo] -searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) - (listUnitInfoMap dflags) +searchPackageId :: PackageState -> SourcePackageId -> [UnitInfo] +searchPackageId pkgstate pid = filter ((pid ==) . sourcePackageId) + (listUnitInfoMap pkgstate) -- | Extends the package configuration map with a list of package configs. extendUnitInfoMap @@ -441,15 +445,15 @@ Just config -> config Nothing -> pprPanic "getPackageDetails" (ppr pid) -lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe UnitInfo -lookupInstalledPackage dflags uid = lookupInstalledPackage' (unitInfoMap (pkgState dflags)) uid +lookupInstalledPackage :: PackageState -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid lookupInstalledPackage' :: UnitInfoMap -> InstalledUnitId -> Maybe UnitInfo lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid -getInstalledPackageDetails :: HasDebugCallStack => DynFlags -> InstalledUnitId -> UnitInfo -getInstalledPackageDetails dflags uid = - case lookupInstalledPackage dflags uid of +getInstalledPackageDetails :: HasDebugCallStack => PackageState -> InstalledUnitId -> UnitInfo +getInstalledPackageDetails pkgstate uid = + case lookupInstalledPackage pkgstate uid of Just config -> config Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid) @@ -457,10 +461,10 @@ -- this function, although all packages in this map are "visible", this -- does not imply that the exposed-modules of the package are available -- (they may have been thinned or renamed). -listUnitInfoMap :: DynFlags -> [UnitInfo] -listUnitInfoMap dflags = eltsUDFM pkg_map +listUnitInfoMap :: PackageState -> [UnitInfo] +listUnitInfoMap pkgstate = eltsUDFM pkg_map where - UnitInfoMap pkg_map _ = unitInfoMap (pkgState dflags) + UnitInfoMap pkg_map _ = unitInfoMap pkgstate -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -994,7 +998,7 @@ -- ----------------------------------------------------------------------------- -- Wired-in packages -- --- See Note [Wired-in packages] in Module +-- See Note [Wired-in packages] in GHC.Types.Module type WiredInUnitId = String type WiredPackagesMap = Map WiredUnitId WiredUnitId @@ -1014,7 +1018,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do -- Now we must find our wired-in packages, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in packages] in Module + -- in Note [Wired-in packages] in GHC.Types.Module let matches :: UnitInfo -> WiredInUnitId -> Bool pc `matches` pid @@ -1073,6 +1077,7 @@ mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_unitids let wired_in_pkgs = catMaybes mb_wired_in_pkgs + pkgstate = pkgState dflags -- this is old: we used to assume that if there were -- multiple versions of wired-in packages installed that @@ -1101,7 +1106,7 @@ = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) in pkg { unitId = fsToInstalledUnitId fs, - componentId = ComponentId fs + componentId = mkComponentId pkgstate fs } | otherwise = pkg @@ -1118,7 +1123,7 @@ -- Helper functions for rewiring Module and UnitId. These -- rewrite UnitIds of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in packages] in Module. +-- compiler, as described in Note [Wired-in packages] in GHC.Types.Module. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in PrelNames. @@ -1839,22 +1844,22 @@ where ways0 = ways dflags - ways1 = filter (/= WayDyn) ways0 + ways1 = Set.filter (/= WayDyn) ways0 -- the name of a shared library is libHSfoo-ghc.so -- we leave out the _dyn, because it is superfluous -- debug and profiled RTSs include support for -eventlog - ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 - = filter (/= WayEventLog) ways1 + ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 + = Set.filter (/= WayEventLog) ways1 | otherwise = ways1 - tag = mkBuildTag (filter (not . wayRTSOnly) ways2) - rts_tag = mkBuildTag ways2 + tag = waysTag (Set.filter (not . wayRTSOnly) ways2) + rts_tag = waysTag ways2 mkDynName x - | WayDyn `notElem` ways dflags = x - | "HS" `isPrefixOf` x = + | WayDyn `Set.notMember` ways dflags = x + | "HS" `isPrefixOf` x = x ++ '-':programName dflags ++ projectVersion dflags -- For non-Haskell libraries, we use the name "Cfoo". The .a -- file is libCfoo.a, and the .so is libfoo.so. That way the @@ -2053,7 +2058,7 @@ pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) - return (map (getInstalledPackageDetails dflags) all_pkgs) + return (map (getInstalledPackageDetails state) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). @@ -2106,27 +2111,52 @@ -- ----------------------------------------------------------------------------- -componentIdString :: DynFlags -> ComponentId -> Maybe String -componentIdString dflags cid = do - conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) - return $ - case sourceLibName conf of - Nothing -> sourcePackageIdString conf - Just (PackageName libname) -> - packageNameString conf - ++ "-" ++ showVersion (packageVersion conf) - ++ ":" ++ unpackFS libname +componentIdString :: ComponentId -> String +componentIdString (ComponentId raw Nothing) = unpackFS raw +componentIdString (ComponentId _raw (Just details)) = + case componentName details of + Nothing -> componentSourcePkdId details + Just cname -> componentPackageName details + ++ "-" ++ showVersion (componentPackageVersion details) + ++ ":" ++ cname -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String -displayInstalledUnitId dflags uid = - fmap sourcePackageIdString (lookupInstalledPackage dflags uid) +-- Cabal packages may contain several components (programs, libraries, etc.). +-- As far as GHC is concerned, installed package components ("units") are +-- identified by an opaque ComponentId string provided by Cabal. As the string +-- contains a hash, we don't want to display it to users so GHC queries the +-- database to retrieve some infos about the original source package (name, +-- version, component name). +-- +-- Instead we want to display: packagename-version[:componentname] +-- +-- Component name is only displayed if it isn't the default library +-- +-- To do this we need to query the database (cached in DynFlags). We cache +-- these details in the ComponentId itself because we don't want to query +-- DynFlags each time we pretty-print the ComponentId +-- +mkComponentId :: PackageState -> FastString -> ComponentId +mkComponentId pkgstate raw = + case lookupInstalledPackage pkgstate (InstalledUnitId raw) of + Nothing -> ComponentId raw Nothing -- we didn't find the unit at all + Just c -> ComponentId raw $ Just $ ComponentDetails + (packageNameString c) + (packageVersion c) + ((unpackFS . unPackageName) <$> sourceLibName c) + (sourcePackageIdString c) --- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> Module -> Name -> Bool --- Despite the "dll", I think this function just means that --- the symbol comes from another dynamically-linked package, --- and applies on all platforms, not just Windows -isDllName dflags this_mod name +-- | Update component ID details from the database +updateComponentId :: PackageState -> ComponentId -> ComponentId +updateComponentId pkgstate (ComponentId raw _) = mkComponentId pkgstate raw + + +displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String +displayInstalledUnitId pkgstate uid = + fmap sourcePackageIdString (lookupInstalledPackage pkgstate uid) + +-- | Will the 'Name' come from a dynamically linked package? +isDynLinkName :: DynFlags -> Module -> Name -> Bool +isDynLinkName dflags this_mod name | not (gopt Opt_ExternalDynamicRefs dflags) = False | Just mod <- nameModule_maybe name -- Issue #8696 - when GHC is dynamically linked, it will attempt @@ -2136,7 +2166,7 @@ -- intra-package linking, because we don't generate indirect -- (dynamic) symbols for intra-package calls. This means that if a -- module with an intra-package call is loaded without its - -- dependencies, then GHC fails to link. This is the cause of # + -- dependencies, then GHC fails to link. -- -- In the mean time, always force dynamic indirections to be -- generated: when the module name isn't the module being @@ -2161,18 +2191,18 @@ -- Displaying packages -- | Show (very verbose) package info -pprPackages :: DynFlags -> SDoc +pprPackages :: PackageState -> SDoc pprPackages = pprPackagesWith pprUnitInfo -pprPackagesWith :: (UnitInfo -> SDoc) -> DynFlags -> SDoc -pprPackagesWith pprIPI dflags = - vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap dflags))) +pprPackagesWith :: (UnitInfo -> SDoc) -> PackageState -> SDoc +pprPackagesWith pprIPI pkgstate = + vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap pkgstate))) -- | Show simplified package info. -- -- The idea is to only print package id, and any information that might -- be different from the package databases (exposure, trust) -pprPackagesSimple :: DynFlags -> SDoc +pprPackagesSimple :: PackageState -> SDoc pprPackagesSimple = pprPackagesWith pprIPI where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) e = if exposed ipi then text "E" else text " " @@ -2213,3 +2243,8 @@ -- in the @hs-boot@ loop-breaker. getUnitInfoMap :: DynFlags -> UnitInfoMap getUnitInfoMap = unitInfoMap . pkgState + +-- | Retrieve the 'PackageState' from 'DynFlags'; used +-- in the @hs-boot@ loop-breaker. +getPackageState :: DynFlags -> PackageState +getPackageState = pkgState diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot --- a/compiler/GHC/Driver/Packages.hs-boot +++ b/compiler/GHC/Driver/Packages.hs-boot @@ -1,12 +1,15 @@ module GHC.Driver.Packages where import GhcPrelude +import FastString import {-# SOURCE #-} GHC.Driver.Session (DynFlags) -import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) +import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId) data PackageState data UnitInfoMap data PackageDatabase emptyPackageState :: PackageState -componentIdString :: DynFlags -> ComponentId -> Maybe String -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +componentIdString :: ComponentId -> String +mkComponentId :: PackageState -> FastString -> ComponentId +displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String improveUnitId :: UnitInfoMap -> UnitId -> UnitId getUnitInfoMap :: DynFlags -> UnitInfoMap +getPackageState :: DynFlags -> PackageState diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -41,7 +41,6 @@ import GhcPrelude -import {-# SOURCE #-} GHC.Driver.Session import Outputable import GHC.Platform import System.FilePath @@ -198,15 +197,15 @@ possible for a ghc-api user to do so. So be careful when using the function happensBefore, and don't think that `not (a <= b)` implies `b < a`. -} -happensBefore :: DynFlags -> Phase -> Phase -> Bool -happensBefore dflags p1 p2 = p1 `happensBefore'` p2 +happensBefore :: Platform -> Phase -> Phase -> Bool +happensBefore platform p1 p2 = p1 `happensBefore'` p2 where StopLn `happensBefore'` _ = False x `happensBefore'` y = after_x `eqPhase` y || after_x `happensBefore'` y - where after_x = nextPhase dflags x + where after_x = nextPhase platform x -nextPhase :: DynFlags -> Phase -> Phase -nextPhase dflags p +nextPhase :: Platform -> Phase -> Phase +nextPhase platform p -- A conservative approximation to the next phase, used in happensBefore = case p of Unlit sf -> Cpp sf @@ -226,7 +225,7 @@ HCc -> As False MergeForeign -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" - where maybeHCc = if platformUnregisterised (targetPlatform dflags) + where maybeHCc = if platformUnregisterised platform then HCc else As False diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -18,7 +18,7 @@ import GHC.Driver.Session import GHC.Driver.Phases import GHC.Driver.Types -import Module +import GHC.Types.Module import FileCleanup (TempFileLifetime) import Control.Monad diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -49,7 +49,7 @@ import GhcPrelude -import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) +import {-# SOURCE #-} GHC.Core.Op.Monad ( CoreToDo, CoreM ) import qualified TcRnTypes import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import TcHoleFitTypes ( HoleFitPluginR ) @@ -58,7 +58,7 @@ import GHC.Driver.Types import GHC.Driver.Monad import GHC.Driver.Phases -import Module ( ModuleName, Module(moduleName)) +import GHC.Types.Module ( ModuleName, Module(moduleName)) import Fingerprint import Data.List (sort) import Outputable (Outputable(..), text, (<+>)) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -65,8 +65,7 @@ optimisationFlags, setFlagsFromEnvFile, - Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, - wayGeneralFlags, wayUnsetGeneralFlags, + addWay', updateWays, thisPackage, thisComponentId, thisUnitIdInsts, @@ -163,8 +162,6 @@ addPluginModuleName, defaultDynFlags, -- Settings -> DynFlags defaultWays, - interpWays, - interpreterProfiled, interpreterDynamic, initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, defaultLogAction, @@ -202,16 +199,11 @@ -- * Compiler configuration suitable for display to the user compilerInfo, - rtsIsProfiled, - dynamicGhc, - #include "GHCConstantsHaskellExports.hs" bLOCK_SIZE_W, - wORD_SIZE_IN_BITS, wordAlignment, tAG_MASK, mAX_PTR_TAG, - tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, @@ -242,7 +234,7 @@ initSDocContext, -- * Make use of the Cmm CFG - CfgWeights(..), backendMaintainsCfg + CfgWeights(..) ) where #include "HsVersions.h" @@ -252,12 +244,14 @@ import GHC.Platform import GHC.UniqueSubdir (uniqueSubdir) import PlatformConstants -import Module +import GHC.Types.Module import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks import {-# SOURCE #-} PrelNames ( mAIN ) -import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase) +import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase, mkComponentId) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) +import GHC.Driver.Flags +import GHC.Driver.Ways import Config import CliOption import GHC.Driver.CmdLine hiding (WarnReason(..)) @@ -270,8 +264,8 @@ import Maybes import MonadUtils import qualified Pretty -import SrcLoc -import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) +import GHC.Types.SrcLoc +import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import FastString import Fingerprint import FileSettings @@ -279,8 +273,6 @@ import Settings import ToolSettings -import Foreign.C ( CInt(..) ) -import System.IO.Unsafe ( unsafeDupablePerformIO ) import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn , getCaretDiagnostic, DumpAction, TraceAction , defaultDumpAction, defaultTraceAction ) @@ -300,13 +292,11 @@ 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) @@ -401,413 +391,7 @@ -- ----------------------------------------------------------------------------- -- DynFlags -data DumpFlag --- See Note [Updating flag description in the User's Guide] - -- debugging flags - = Opt_D_dump_cmm - | Opt_D_dump_cmm_from_stg - | Opt_D_dump_cmm_raw - | Opt_D_dump_cmm_verbose_by_proc - -- All of the cmm subflags (there are a lot!) automatically - -- enabled if you run -ddump-cmm-verbose-by-proc - -- Each flag corresponds to exact stage of Cmm pipeline. - | Opt_D_dump_cmm_verbose - -- same as -ddump-cmm-verbose-by-proc but writes each stage - -- to a separate file (if used with -ddump-to-file) - | Opt_D_dump_cmm_cfg - | Opt_D_dump_cmm_cbe - | Opt_D_dump_cmm_switch - | Opt_D_dump_cmm_proc - | Opt_D_dump_cmm_sp - | Opt_D_dump_cmm_sink - | Opt_D_dump_cmm_caf - | Opt_D_dump_cmm_procmap - | Opt_D_dump_cmm_split - | Opt_D_dump_cmm_info - | Opt_D_dump_cmm_cps - -- end cmm subflags - | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. - | Opt_D_dump_asm - | Opt_D_dump_asm_native - | Opt_D_dump_asm_liveness - | Opt_D_dump_asm_regalloc - | Opt_D_dump_asm_regalloc_stages - | Opt_D_dump_asm_conflicts - | Opt_D_dump_asm_stats - | Opt_D_dump_asm_expanded - | Opt_D_dump_llvm - | Opt_D_dump_core_stats - | Opt_D_dump_deriv - | Opt_D_dump_ds - | Opt_D_dump_ds_preopt - | Opt_D_dump_foreign - | Opt_D_dump_inlinings - | Opt_D_dump_rule_firings - | Opt_D_dump_rule_rewrites - | Opt_D_dump_simpl_trace - | Opt_D_dump_occur_anal - | Opt_D_dump_parsed - | Opt_D_dump_parsed_ast - | Opt_D_dump_rn - | Opt_D_dump_rn_ast - | Opt_D_dump_simpl - | Opt_D_dump_simpl_iterations - | Opt_D_dump_spec - | Opt_D_dump_prep - | Opt_D_dump_stg -- CoreToStg output - | Opt_D_dump_stg_unarised -- STG after unarise - | Opt_D_dump_stg_final -- STG after stg2stg - | Opt_D_dump_call_arity - | Opt_D_dump_exitify - | Opt_D_dump_stranal - | Opt_D_dump_str_signatures - | Opt_D_dump_cpranal - | Opt_D_dump_cpr_signatures - | Opt_D_dump_tc - | Opt_D_dump_tc_ast - | Opt_D_dump_types - | Opt_D_dump_rules - | Opt_D_dump_cse - | Opt_D_dump_worker_wrapper - | Opt_D_dump_rn_trace - | Opt_D_dump_rn_stats - | Opt_D_dump_opt_cmm - | Opt_D_dump_simpl_stats - | Opt_D_dump_cs_trace -- Constraint solver in type checker - | Opt_D_dump_tc_trace - | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker - | Opt_D_dump_if_trace - | Opt_D_dump_vt_trace - | Opt_D_dump_splices - | Opt_D_th_dec_file - | Opt_D_dump_BCOs - | Opt_D_dump_ticked - | Opt_D_dump_rtti - | Opt_D_source_stats - | Opt_D_verbose_stg2stg - | Opt_D_dump_hi - | Opt_D_dump_hi_diffs - | Opt_D_dump_mod_cycles - | Opt_D_dump_mod_map - | Opt_D_dump_timings - | Opt_D_dump_view_pattern_commoning - | Opt_D_verbose_core2core - | Opt_D_dump_debug - | Opt_D_dump_json - | Opt_D_ppr_debug - | Opt_D_no_debug_output - deriving (Eq, Show, Enum) - - --- | Enumerates the simple on-or-off dynamic flags -data GeneralFlag --- See Note [Updating flag description in the User's Guide] - - = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. - | Opt_D_faststring_stats - | Opt_D_dump_minimal_imports - | Opt_DoCoreLinting - | Opt_DoStgLinting - | Opt_DoCmmLinting - | Opt_DoAsmLinting - | Opt_DoAnnotationLinting - | Opt_NoLlvmMangler -- hidden flag - | Opt_FastLlvm -- hidden flag - | Opt_NoTypeableBinds - - | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_ShowWarnGroups -- Show the group a warning belongs to - | Opt_HideSourcePaths -- Hide module source/object paths - - | Opt_PrintExplicitForalls - | Opt_PrintExplicitKinds - | Opt_PrintExplicitCoercions - | Opt_PrintExplicitRuntimeReps - | Opt_PrintEqualityRelations - | Opt_PrintAxiomIncomps - | Opt_PrintUnicodeSyntax - | Opt_PrintExpandedSynonyms - | Opt_PrintPotentialInstances - | Opt_PrintTypecheckerElaboration - - -- optimisation opts - | Opt_CallArity - | Opt_Exitification - | Opt_Strictness - | Opt_LateDmdAnal -- #6087 - | Opt_KillAbsence - | Opt_KillOneShot - | Opt_FullLaziness - | Opt_FloatIn - | Opt_LateSpecialise - | Opt_Specialise - | Opt_SpecialiseAggressively - | Opt_CrossModuleSpecialise - | Opt_StaticArgumentTransformation - | Opt_CSE - | Opt_StgCSE - | Opt_StgLiftLams - | Opt_LiberateCase - | Opt_SpecConstr - | Opt_SpecConstrKeen - | Opt_DoLambdaEtaExpansion - | Opt_IgnoreAsserts - | Opt_DoEtaReduction - | Opt_CaseMerge - | Opt_CaseFolding -- Constant folding through case-expressions - | Opt_UnboxStrictFields - | Opt_UnboxSmallStrictFields - | Opt_DictsCheap - | Opt_EnableRewriteRules -- Apply rewrite rules during simplification - | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices - | Opt_RegsGraph -- do graph coloring register allocation - | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation - | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infrastructure for improving AA (hidden flag) - | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) - | Opt_IrrefutableTuples - | Opt_CmmSink - | Opt_CmmElimCommonBlocks - | Opt_AsmShortcutting - | Opt_OmitYields - | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas - | Opt_DictsStrict -- be strict in argument dictionaries - | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors - | Opt_Loopification -- See Note [Self-recursive tail calls] - | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. - | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. - | Opt_CprAnal - | Opt_WorkerWrapper - | Opt_SolveConstantDicts - | Opt_AlignmentSanitisation - | Opt_CatchBottoms - | Opt_NumConstantFolding - - -- PreInlining is on by default. The option is there just to see how - -- bad things get if you turn it off! - | Opt_SimplPreInlining - - -- Interface files - | Opt_IgnoreInterfacePragmas - | Opt_OmitInterfacePragmas - | Opt_ExposeAllUnfoldings - | Opt_WriteInterface -- forces .hi files to be written even with -fno-code - | Opt_WriteHie -- generate .hie files - - -- profiling opts - | Opt_AutoSccsOnIndividualCafs - | Opt_ProfCountEntries - - -- misc opts - | Opt_Pp - | Opt_ForceRecomp - | Opt_IgnoreOptimChanges - | Opt_IgnoreHpcChanges - | Opt_ExcessPrecision - | Opt_EagerBlackHoling - | Opt_NoHsMain - | Opt_SplitSections - | Opt_StgStats - | Opt_HideAllPackages - | Opt_HideAllPluginPackages - | Opt_PrintBindResult - | Opt_Haddock - | Opt_HaddockOptions - | Opt_BreakOnException - | Opt_BreakOnError - | Opt_PrintEvldWithShow - | Opt_PrintBindContents - | Opt_GenManifest - | Opt_EmbedManifest - | Opt_SharedImplib - | Opt_BuildingCabalPackage - | Opt_IgnoreDotGhci - | Opt_GhciSandbox - | Opt_GhciHistory - | Opt_GhciLeakCheck - | Opt_ValidateHie - | Opt_LocalGhciHistory - | Opt_NoIt - | Opt_HelpfulErrors - | Opt_DeferTypeErrors - | Opt_DeferTypedHoles - | Opt_DeferOutOfScopeVariables - | Opt_PIC -- ^ @-fPIC@ - | Opt_PIE -- ^ @-fPIE@ - | Opt_PICExecutable -- ^ @-pie@ - | Opt_ExternalDynamicRefs - | Opt_SccProfilingOn - | Opt_Ticky - | Opt_Ticky_Allocd - | Opt_Ticky_LNE - | Opt_Ticky_Dyn_Thunk - | Opt_RPath - | Opt_RelativeDynlibPaths - | Opt_Hpc - | Opt_FlatCache - | Opt_ExternalInterpreter - | Opt_OptimalApplicativeDo - | Opt_VersionMacros - | Opt_WholeArchiveHsLibs - -- copy all libs into a single folder prior to linking binaries - -- this should elivate the excessive command line limit restrictions - -- on windows, by only requiring a single -L argument instead of - -- one for each dependency. At the time of this writing, gcc - -- forwards all -L flags to the collect2 command without using a - -- response file and as such breaking apart. - | Opt_SingleLibFolder - | Opt_KeepCAFs - | Opt_KeepGoing - | Opt_ByteCode - - -- output style opts - | Opt_ErrorSpans -- Include full span info in error messages, - -- instead of just the start position. - | Opt_DeferDiagnostics - | Opt_DiagnosticsShowCaret -- Show snippets of offending code - | Opt_PprCaseAsLet - | Opt_PprShowTicks - | Opt_ShowHoleConstraints - -- Options relating to the display of valid hole fits - -- when generating an error message for a typed hole - -- See Note [Valid hole fits include] in TcHoleErrors.hs - | Opt_ShowValidHoleFits - | Opt_SortValidHoleFits - | Opt_SortBySizeHoleFits - | Opt_SortBySubsumHoleFits - | Opt_AbstractRefHoleFits - | Opt_UnclutterValidHoleFits - | Opt_ShowTypeAppOfHoleFits - | Opt_ShowTypeAppVarsOfHoleFits - | Opt_ShowDocsOfHoleFits - | Opt_ShowTypeOfHoleFits - | Opt_ShowProvOfHoleFits - | Opt_ShowMatchesOfHoleFits - - | Opt_ShowLoadedModules - | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] - - -- Suppress all coercions, them replacing with '...' - | Opt_SuppressCoercions - | Opt_SuppressVarKinds - -- Suppress module id prefixes on variables. - | Opt_SuppressModulePrefixes - -- Suppress type applications. - | Opt_SuppressTypeApplications - -- Suppress info such as arity and unfoldings on identifiers. - | Opt_SuppressIdInfo - -- Suppress separate type signatures in core, but leave types on - -- lambda bound vars - | Opt_SuppressUnfoldings - -- Suppress the details of even stable unfoldings - | Opt_SuppressTypeSignatures - -- Suppress unique ids on variables. - -- Except for uniques, as some simplifier phases introduce new - -- variables that have otherwise identical names. - | Opt_SuppressUniques - | Opt_SuppressStgExts - | Opt_SuppressTicks -- Replaces Opt_PprShowTicks - | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps - - -- temporary flags - | Opt_AutoLinkPackages - | Opt_ImplicitImportQualified - - -- keeping stuff - | Opt_KeepHscppFiles - | Opt_KeepHiDiffs - | Opt_KeepHcFiles - | Opt_KeepSFiles - | Opt_KeepTmpFiles - | Opt_KeepRawTokenStream - | Opt_KeepLlvmFiles - | Opt_KeepHiFiles - | Opt_KeepOFiles - - | Opt_BuildDynamicToo - - -- safe haskell flags - | Opt_DistrustAllPackages - | Opt_PackageTrust - | Opt_PluginTrustworthy - - | Opt_G_NoStateHack - | Opt_G_NoOptCoercion - deriving (Eq, Show, Enum) - --- Check whether a flag should be considered an "optimisation flag" --- for purposes of recompilation avoidance (see --- Note [Ignoring some flag changes] in FlagChecker). Being listed here is --- not a guarantee that the flag has no other effect. We could, and --- perhaps should, separate out the flags that have some minor impact on --- program semantics and/or error behavior (e.g., assertions), but --- then we'd need to go to extra trouble (and an additional flag) --- to allow users to ignore the optimisation level even though that --- means ignoring some change. -optimisationFlags :: EnumSet GeneralFlag -optimisationFlags = EnumSet.fromList - [ Opt_CallArity - , Opt_Strictness - , Opt_LateDmdAnal - , Opt_KillAbsence - , Opt_KillOneShot - , Opt_FullLaziness - , Opt_FloatIn - , Opt_LateSpecialise - , Opt_Specialise - , Opt_SpecialiseAggressively - , Opt_CrossModuleSpecialise - , Opt_StaticArgumentTransformation - , Opt_CSE - , Opt_StgCSE - , Opt_StgLiftLams - , Opt_LiberateCase - , Opt_SpecConstr - , Opt_SpecConstrKeen - , Opt_DoLambdaEtaExpansion - , Opt_IgnoreAsserts - , Opt_DoEtaReduction - , Opt_CaseMerge - , Opt_CaseFolding - , Opt_UnboxStrictFields - , Opt_UnboxSmallStrictFields - , Opt_DictsCheap - , Opt_EnableRewriteRules - , Opt_RegsGraph - , Opt_RegsIterative - , Opt_PedanticBottoms - , Opt_LlvmTBAA - , Opt_LlvmFillUndefWithGarbage - , Opt_IrrefutableTuples - , Opt_CmmSink - , Opt_CmmElimCommonBlocks - , Opt_AsmShortcutting - , Opt_OmitYields - , Opt_FunToThunk - , Opt_DictsStrict - , Opt_DmdTxDictSel - , Opt_Loopification - , Opt_CfgBlocklayout - , Opt_WeightlessBlocklayout - , Opt_CprAnal - , Opt_WorkerWrapper - , Opt_SolveConstantDicts - , Opt_CatchBottoms - , Opt_IgnoreAsserts - ] - --- | Used when outputting warnings: if a reason is given, it is --- displayed. If a warning isn't controlled by a flag, this is made --- explicit at the point of use. -data WarnReason - = NoReason - -- | Warning was enabled with the flag - | Reason !WarningFlag - -- | Warning was made an error because of -Werror or -Werror=WarningFlag - | ErrReason !(Maybe WarningFlag) - deriving Show - -- | Used to differentiate the scope an include needs to apply to. -- We have to split the include paths to avoid accidentally forcing recursive -- includes since -I overrides the system search paths. See #14312. @@ -835,107 +419,6 @@ flattenIncludes :: IncludeSpecs -> [String] flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json (Reason wf) = JSString (show wf) - json (ErrReason Nothing) = JSString "Opt_WarnIsError" - json (ErrReason (Just wf)) = JSString (show wf) - -data WarningFlag = --- See Note [Updating flag description in the User's Guide] - Opt_WarnDuplicateExports - | Opt_WarnDuplicateConstraints - | Opt_WarnRedundantConstraints - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompleteUniPatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnOverflowedLiterals - | Opt_WarnEmptyEnumerations - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSignatures - | Opt_WarnMissingLocalSignatures - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedTopBinds - | Opt_WarnUnusedLocalBinds - | Opt_WarnUnusedPatternBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnUnusedTypePatterns - | Opt_WarnUnusedForalls - | Opt_WarnUnusedRecordWildcards - | Opt_WarnRedundantRecordWildcards - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8 - | Opt_WarnSemigroup -- since 8.0 - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnIdentities - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional - | Opt_WarnUnsafe - | Opt_WarnSafe - | Opt_WarnTrustworthySafe - | Opt_WarnMissedSpecs - | Opt_WarnAllMissedSpecs - | Opt_WarnUnsupportedCallingConventions - | Opt_WarnUnsupportedLlvmVersion - | Opt_WarnMissedExtraSharedLib - | Opt_WarnInlineRuleShadowing - | Opt_WarnTypedHoles - | Opt_WarnPartialTypeSignatures - | Opt_WarnMissingExportedSignatures - | Opt_WarnUntickedPromotedConstructors - | Opt_WarnDerivingTypeable - | Opt_WarnDeferredTypeErrors - | Opt_WarnDeferredOutOfScopeVariables - | Opt_WarnNonCanonicalMonadInstances -- since 8.0 - | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 - | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 - | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 - | Opt_WarnUnrecognisedWarningFlags -- since 8.0 - | Opt_WarnSimplifiableClassConstraints -- Since 8.2 - | Opt_WarnCPPUndef -- Since 8.2 - | Opt_WarnUnbangedStrictPatterns -- Since 8.2 - | Opt_WarnMissingHomeModules -- Since 8.2 - | Opt_WarnPartialFields -- Since 8.4 - | Opt_WarnMissingExportList - | Opt_WarnInaccessibleCode - | Opt_WarnStarIsType -- Since 8.6 - | Opt_WarnStarBinder -- Since 8.6 - | Opt_WarnImplicitKindVars -- Since 8.6 - | Opt_WarnSpaceAfterBang - | Opt_WarnMissingDerivingStrategies -- Since 8.8 - | Opt_WarnPrepositiveQualifiedModule -- Since TBD - | Opt_WarnUnusedPackages -- Since 8.10 - | Opt_WarnInferredSafeImports -- Since 8.10 - | Opt_WarnMissingSafeHaskellMode -- Since 8.10 - | Opt_WarnCompatUnqualifiedImports -- Since 8.10 - | Opt_WarnDerivingDefaults - deriving (Eq, Show, Enum) - -data Language = Haskell98 | Haskell2010 - deriving (Eq, Enum, Show) - -instance Outputable Language where - ppr = text . show - -- | The various Safe Haskell modes data SafeHaskellMode = Sf_None -- ^ inferred unsafe @@ -1021,7 +504,7 @@ -- by the assembler code generator (0 to disable) liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating - -- See CoreMonad.FloatOutSwitches + -- See GHC.Core.Op.Monad.FloatOutSwitches liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a -- recursive function. @@ -1046,7 +529,7 @@ thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], -- ways - ways :: [Way], -- ^ Way flags from the command line + ways :: Set Way, -- ^ Way flags from the command line buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) -- For object splitting @@ -1366,12 +849,6 @@ ",likelyCondWeight=900,unlikelyCondWeight=300" ++ ",infoTablePenalty=300,backEdgeBonus=400" -backendMaintainsCfg :: DynFlags -> Bool -backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of - -- ArchX86 -- Should work but not tested so disabled currently. - ArchX86_64 -> True - _otherwise -> False - class HasDynFlags m where getDynFlags :: m DynFlags @@ -1710,143 +1187,6 @@ positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags ------------------------------------------------------------------------------ --- Ways - --- The central concept of a "way" is that all objects in a given --- program must be compiled in the same "way". Certain options change --- parameters of the virtual machine, eg. profiling adds an extra word --- to the object header, so profiling objects cannot be linked with --- non-profiling objects. - --- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+threaded. - --- We then find the "build-tag" associated with this way, and this --- becomes the suffix used to find .hi files and libraries used in --- this compilation. - -data Way - = WayCustom String -- for GHC API clients building custom variants - | WayThreaded - | WayDebug - | WayProf - | WayEventLog - | WayDyn - deriving (Eq, Ord, Show) - -allowed_combination :: [Way] -> Bool -allowed_combination way = and [ x `allowedWith` y - | x <- way, y <- way, x < y ] - where - -- Note ordering in these tests: the left argument is - -- <= the right argument, according to the Ord instance - -- on Way above. - - -- dyn is allowed with everything - _ `allowedWith` WayDyn = True - WayDyn `allowedWith` _ = True - - -- debug is allowed with everything - _ `allowedWith` WayDebug = True - WayDebug `allowedWith` _ = True - - (WayCustom {}) `allowedWith` _ = True - WayThreaded `allowedWith` WayProf = True - WayThreaded `allowedWith` WayEventLog = True - WayProf `allowedWith` WayEventLog = True - _ `allowedWith` _ = False - -mkBuildTag :: [Way] -> String -mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) - -wayTag :: Way -> String -wayTag (WayCustom xs) = xs -wayTag WayThreaded = "thr" -wayTag WayDebug = "debug" -wayTag WayDyn = "dyn" -wayTag WayProf = "p" -wayTag WayEventLog = "l" - -wayRTSOnly :: Way -> Bool -wayRTSOnly (WayCustom {}) = False -wayRTSOnly WayThreaded = True -wayRTSOnly WayDebug = True -wayRTSOnly WayDyn = False -wayRTSOnly WayProf = False -wayRTSOnly WayEventLog = True - -wayDesc :: Way -> String -wayDesc (WayCustom xs) = xs -wayDesc WayThreaded = "Threaded" -wayDesc WayDebug = "Debug" -wayDesc WayDyn = "Dynamic" -wayDesc WayProf = "Profiling" -wayDesc WayEventLog = "RTS Event Logging" - --- Turn these flags on when enabling this way -wayGeneralFlags :: Platform -> Way -> [GeneralFlag] -wayGeneralFlags _ (WayCustom {}) = [] -wayGeneralFlags _ WayThreaded = [] -wayGeneralFlags _ WayDebug = [] -wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] - -- We could get away without adding -fPIC when compiling the - -- modules of a program that is to be linked with -dynamic; the - -- program itself does not need to be position-independent, only - -- the libraries need to be. HOWEVER, GHCi links objects into a - -- .so before loading the .so using the system linker. Since only - -- PIC objects can be linked into a .so, we have to compile even - -- modules of the main program with -fPIC when using -dynamic. -wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] -wayGeneralFlags _ WayEventLog = [] - --- Turn these flags off when enabling this way -wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] -wayUnsetGeneralFlags _ (WayCustom {}) = [] -wayUnsetGeneralFlags _ WayThreaded = [] -wayUnsetGeneralFlags _ WayDebug = [] -wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting - -- when we're going to be dynamically - -- linking. Plus it breaks compilation - -- on OSX x86. - Opt_SplitSections] -wayUnsetGeneralFlags _ WayProf = [] -wayUnsetGeneralFlags _ WayEventLog = [] - -wayOptc :: Platform -> Way -> [String] -wayOptc _ (WayCustom {}) = [] -wayOptc platform WayThreaded = case platformOS platform of - OSOpenBSD -> ["-pthread"] - OSNetBSD -> ["-pthread"] - _ -> [] -wayOptc _ WayDebug = [] -wayOptc _ WayDyn = [] -wayOptc _ WayProf = ["-DPROFILING"] -wayOptc _ WayEventLog = ["-DTRACING"] - -wayOptl :: Platform -> Way -> [String] -wayOptl _ (WayCustom {}) = [] -wayOptl platform WayThreaded = - case platformOS platform of - -- N.B. FreeBSD cc throws a warning if we pass -pthread without - -- actually using any pthread symbols. - OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] - OSOpenBSD -> ["-pthread"] - OSNetBSD -> ["-pthread"] - _ -> [] -wayOptl _ WayDebug = [] -wayOptl _ WayDyn = [] -wayOptl _ WayProf = [] -wayOptl _ WayEventLog = [] - -wayOptP :: Platform -> Way -> [String] -wayOptP _ (WayCustom {}) = [] -wayOptP _ WayThreaded = [] -wayOptP _ WayDebug = [] -wayOptP _ WayDyn = [] -wayOptP _ WayProf = ["-DPROFILING"] -wayOptP _ WayEventLog = ["-DTRACING"] - whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) @@ -2039,7 +1379,7 @@ pkgDatabase = Nothing, pkgState = emptyPackageState, ways = defaultWays mySettings, - buildTag = mkBuildTag (defaultWays mySettings), + buildTag = waysTag (defaultWays mySettings), splitInfo = Nothing, ghcNameVersion = sGhcNameVersion mySettings, @@ -2145,26 +1485,10 @@ cfgWeightInfo = defaultCfgWeights } -defaultWays :: Settings -> [Way] +defaultWays :: Settings -> Set Way defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) - then [WayDyn] - else [] - -interpWays :: [Way] -interpWays - | dynamicGhc = [WayDyn] - | rtsIsProfiled = [WayProf] - | otherwise = [] - -interpreterProfiled :: DynFlags -> Bool -interpreterProfiled dflags - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags - | otherwise = rtsIsProfiled - -interpreterDynamic :: DynFlags -> Bool -interpreterDynamic dflags - | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags - | otherwise = dynamicGhc + then Set.singleton WayDyn + else Set.empty -------------------------------------------------------------------------- -- @@ -2636,13 +1960,14 @@ thisComponentId :: DynFlags -> ComponentId thisComponentId dflags = - case thisComponentId_ dflags of - Just cid -> cid + let pkgstate = pkgState dflags + in case thisComponentId_ dflags of + Just (ComponentId raw _) -> mkComponentId pkgstate raw Nothing -> case thisUnitIdInsts_ dflags of Just _ -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") - Nothing -> ComponentId (unitIdFS (thisPackage dflags)) + Nothing -> mkComponentId pkgstate (unitIdFS (thisPackage dflags)) thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] thisUnitIdInsts dflags = @@ -2679,7 +2004,7 @@ setComponentId :: String -> DynFlags -> DynFlags setComponentId s d = - d { thisComponentId_ = Just (ComponentId (fsLit s)) } + d { thisComponentId_ = Just (ComponentId (fsLit s) Nothing) } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -2822,7 +2147,7 @@ unless (allowed_combination theWays) $ liftIO $ throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ - intercalate "/" (map wayDesc theWays))) + intercalate "/" (map wayDesc (Set.toAscList theWays)))) let chooseOutput | isJust (outputFile dflags3) -- Only iff user specified -o ... @@ -2855,11 +2180,9 @@ updateWays :: DynFlags -> DynFlags updateWays dflags - = let theWays = sort $ nub $ ways dflags - in dflags { - ways = theWays, - buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) - } + = dflags { + buildTag = waysTag (Set.filter (not . wayRTSOnly) (ways dflags)) + } -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. @@ -3246,6 +2569,7 @@ , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "no-haddock" (NoArg (unSetGeneralFlag Opt_Haddock)) , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) @@ -4243,8 +3567,6 @@ 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, @@ -4981,21 +4303,6 @@ , LangExt.UnicodeSyntax , LangExt.UnliftedFFITypes ] -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt - --- | Was the runtime system built with profiling enabled? -rtsIsProfiled :: Bool -rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 - --- Consult the RTS to find whether GHC itself has been built with --- dynamic linking. This can't be statically known at compile-time, --- because we build both the static and dynamic versions together with --- -dynamic-too. -foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt - -dynamicGhc :: Bool -dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 - setWarnSafe :: Bool -> DynP () setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) setWarnSafe False = return () @@ -5082,7 +4389,7 @@ addWay' :: Way -> DynFlags -> DynFlags addWay' w dflags0 = let platform = targetPlatform dflags0 - dflags1 = dflags0 { ways = w : ways dflags0 } + dflags1 = dflags0 { ways = Set.insert w (ways dflags0) } dflags2 = foldr setGeneralFlag' dflags1 (wayGeneralFlags platform w) dflags3 = foldr unSetGeneralFlag' dflags2 @@ -5090,7 +4397,7 @@ in dflags3 removeWayDyn :: DynP () -removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) +removeWayDyn = upd (\dfs -> dfs { ways = Set.filter (WayDyn /=) (ways dfs) }) -------------------------- setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () @@ -5513,7 +4820,7 @@ -- correctly. They need to reference data in the Haskell -- objects, but can't without -fPIC. See -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code - | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> + | gopt Opt_PIC dflags || WayDyn `Set.member` ways dflags -> ["-fPIC", "-U__PIC__", "-D__PIC__"] -- gcc may be configured to have PIC on by default, let's be -- explicit here, see #15847 @@ -5588,9 +4895,9 @@ -- Whether or not GHC compiles libraries as dynamic by default ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), -- Whether or not GHC was compiled using -dynamic - ("GHC Dynamic", showBool dynamicGhc), + ("GHC Dynamic", showBool hostIsDynamic), -- Whether or not GHC was compiled using -prof - ("GHC Profiled", showBool rtsIsProfiled), + ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), ("LibDir", topDir dflags), -- The path of the global package database used by GHC @@ -5607,13 +4914,11 @@ #include "GHCConstantsHaskellWrappers.hs" bLOCK_SIZE_W :: DynFlags -> Int -bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags - -wORD_SIZE_IN_BITS :: DynFlags -> Int -wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 +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 @@ -5621,22 +4926,6 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -5711,10 +5000,10 @@ | LinkInMemory <- ghcLink dflags , not (gopt Opt_ExternalInterpreter dflags) - , rtsIsProfiled + , hostIsProfiled , isObjectTarget (hscTarget dflags) - , WayProf `notElem` ways dflags - = loop dflags{ways = WayProf : ways dflags} + , WayProf `Set.notMember` ways dflags + = loop dflags{ways = Set.insert WayProf (ways dflags)} "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" | otherwise = (dflags, []) @@ -5910,7 +5199,6 @@ , sdocLineLength = pprCols dflags , sdocCanUseUnicode = useUnicode dflags , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags - , sdocDebugLevel = debugLevel dflags , sdocPprDebug = dopt Opt_D_ppr_debug dflags , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot --- a/compiler/GHC/Driver/Session.hs-boot +++ b/compiler/GHC/Driver/Session.hs-boot @@ -5,8 +5,6 @@ import {-# SOURCE #-} Outputable data DynFlags -data DumpFlag -data GeneralFlag targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -159,46 +159,47 @@ import GHC.Runtime.Interpreter.Types (Interp) import GHC.ForeignSrcLang -import UniqFM +import GHC.Types.Unique.FM import GHC.Hs -import RdrName -import Avail -import Module -import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) -import FamInstEnv +import GHC.Types.Name.Reader +import GHC.Types.Avail +import GHC.Types.Module +import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import GHC.Core.FamInstEnv import GHC.Core ( CoreProgram, RuleBase, CoreRule ) -import Name -import NameEnv -import VarSet -import Var -import Id -import IdInfo ( IdDetails(..), RecSelParent(..)) -import Type +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..)) +import GHC.Core.Type import ApiAnnotation ( ApiAnns ) -import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import PatSyn +import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import TysWiredIn import GHC.Driver.Packages hiding ( Version(..) ) import GHC.Driver.CmdLine import GHC.Driver.Session -import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) -import GHC.Driver.Phases ( Phase, HscSource(..), hscSourceString - , isHsBootOrSig, isHsigFile ) +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Driver.Phases + ( Phase, HscSource(..), hscSourceString + , isHsBootOrSig, isHsigFile ) import qualified GHC.Driver.Phases as Phase -import BasicTypes +import GHC.Types.Basic import GHC.Iface.Syntax import Maybes import Outputable -import SrcLoc -import Unique -import UniqDFM +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.DFM import FastString import StringBuffer ( StringBuffer ) import Fingerprint @@ -206,10 +207,10 @@ import Bag import Binary import ErrUtils -import NameCache +import GHC.Types.Name.Cache import GHC.Platform import Util -import UniqDSet +import GHC.Types.Unique.DSet import GHC.Serialized ( Serialized ) import qualified GHC.LanguageExtensions as LangExt @@ -1610,7 +1611,7 @@ global. (b) Having an External Name is important because of Note - [GlobalRdrEnv shadowing] in RdrName + [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName (c) Their types are tidied. This is important, because :info may ask to look at them, and :info expects the things it looks up to have @@ -2007,7 +2008,7 @@ -- database! = False | Just pkgid <- mb_pkgid - , searchPackageId dflags pkgid `lengthIs` 1 + , searchPackageId (pkgState dflags) pkgid `lengthIs` 1 -- this says: we are given a package pkg-0.1@MMM, are there only one -- exposed packages whose package ID is pkg-0.1? = False @@ -2513,7 +2514,7 @@ -- ^ All the plugins used while compiling this module. } deriving( Eq ) - -- Equality used only for old/new comparison in GHC.Iface.Utils.addFingerprints + -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints -- See 'TcRnTypes.ImportAvails' for details on dependencies. instance Binary Dependencies where diff --git a/compiler/GHC/Driver/Ways.hs b/compiler/GHC/Driver/Ways.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Ways.hs @@ -0,0 +1,190 @@ +-- | Ways +-- +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. +-- +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. +-- +-- There are two kinds of ways: +-- - RTS only: only affect the runtime system (RTS) and don't affect code +-- generation (e.g. threaded, debug) +-- - Full ways: affect code generation and the RTS (e.g. profiling, dynamic +-- linking) +-- +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. +module GHC.Driver.Ways + ( Way(..) + , allowed_combination + , wayGeneralFlags + , wayUnsetGeneralFlags + , wayOptc + , wayOptl + , wayOptP + , wayDesc + , wayRTSOnly + , wayTag + , waysTag + -- * Host GHC ways + , hostFullWays + , hostIsProfiled + , hostIsDynamic + ) +where + +import GhcPrelude +import GHC.Platform +import GHC.Driver.Flags + +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List (intersperse) +import System.IO.Unsafe ( unsafeDupablePerformIO ) + +-- | A way +-- +-- Don't change the constructor order as it us used by `waysTag` to create a +-- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal). +data Way + = WayCustom String -- ^ for GHC API clients building custom variants + | WayThreaded -- ^ (RTS only) Multithreaded runtime system + | WayDebug -- ^ Debugging, enable trace messages and extra checks + | WayProf -- ^ Profiling, enable cost-centre stacks and profiling reports + | WayEventLog -- ^ (RTS only) enable event logging + | WayDyn -- ^ Dynamic linking + deriving (Eq, Ord, Show) + + +-- | Check if a combination of ways is allowed +allowed_combination :: Set Way -> Bool +allowed_combination ways = not disallowed + where + disallowed = or [ Set.member ways x && Set.member ways y + | (x,y) <- couples + ] + -- List of disallowed couples of ways + couples = [] -- we don't have any disallowed combination of ways nowadays + +-- | Unique build-tag associated to a list of ways +waysTag :: Set Way -> String +waysTag = concat . intersperse "_" . map wayTag . Set.toAscList + +-- | Unique build-tag associated to a way +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" + +-- | Return true for ways that only impact the RTS, not the generated code +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayEventLog = True + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" + +-- | Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] + -- We could get away without adding -fPIC when compiling the + -- modules of a program that is to be linked with -dynamic; the + -- program itself does not need to be position-independent, only + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] +wayGeneralFlags _ WayEventLog = [] + +-- | Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [Opt_SplitSections] + -- There's no point splitting when we're going to be dynamically linking. + -- Plus it breaks compilation on OSX x86. +wayUnsetGeneralFlags _ WayProf = [] +wayUnsetGeneralFlags _ WayEventLog = [] + +-- | Pass these options to the C compiler when enabling this way +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] +wayOptc _ WayEventLog = ["-DTRACING"] + +-- | Pass these options to linker when enabling this way +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + -- N.B. FreeBSD cc throws a warning if we pass -pthread without + -- actually using any pthread symbols. + OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] +wayOptl _ WayEventLog = [] + +-- | Pass these options to the preprocessor when enabling this way +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] +wayOptP _ WayEventLog = ["-DTRACING"] + + +-- | Consult the RTS to find whether it has been built with profiling enabled. +hostIsProfiled :: Bool +hostIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO Int + +-- | Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +hostIsDynamic :: Bool +hostIsDynamic = unsafeDupablePerformIO rtsIsDynamicIO /= 0 + +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int + +-- | Return host "full" ways (i.e. ways that have an impact on the compilation, +-- not RTS only ways). These ways must be used when compiling codes targeting +-- the internal interpreter. +hostFullWays :: Set Way +hostFullWays = Set.unions + [ if hostIsDynamic then Set.singleton WayDyn else Set.empty + , if hostIsProfiled then Set.singleton WayProf else Set.empty + ] diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -46,15 +46,15 @@ import GHC.Hs.Extension import GHC.Hs.Pat import GHC.Hs.Types -import BasicTypes ( Fixity, WarningTxt ) +import GHC.Types.Basic ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others: import Outputable -import SrcLoc -import Module ( ModuleName ) +import GHC.Types.SrcLoc +import GHC.Types.Module ( ModuleName ) -- libraries: import Data.Data hiding ( Fixity ) diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -34,12 +34,12 @@ import GHC.Hs.Types import GHC.Core import TcEvidence -import Type -import NameSet -import BasicTypes +import GHC.Core.Type +import GHC.Types.Name.Set +import GHC.Types.Basic import Outputable -import SrcLoc -import Var +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var import Bag import FastString import BooleanFormula (LBooleanFormula) @@ -276,9 +276,7 @@ | VarBind { var_ext :: XVarBind idL idR, var_id :: IdP idL, - var_rhs :: LHsExpr idR, -- ^ Located only for consistency - var_inline :: Bool -- ^ True <=> inline this binding regardless - -- (used for implication constraints only) + var_rhs :: LHsExpr idR -- ^ Located only for consistency } -- | Abstraction Bindings @@ -994,7 +992,7 @@ -- For details on above see note [Api annotations] in ApiAnnotation | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | A minimal complete definition pragma -- @@ -1007,7 +1005,7 @@ -- For details on above see note [Api annotations] in ApiAnnotation | MinimalSig (XMinimalSig pass) SourceText (LBooleanFormula (Located (IdP pass))) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | A "set cost centre" pragma for declarations -- @@ -1018,7 +1016,7 @@ -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -103,19 +103,19 @@ import GHC.Hs.Binds import GHC.Hs.Types import GHC.Hs.Doc -import TyCon -import BasicTypes -import Coercion -import ForeignCall +import GHC.Core.TyCon +import GHC.Types.Basic +import GHC.Core.Coercion +import GHC.Types.ForeignCall import GHC.Hs.Extension -import NameSet +import GHC.Types.Name.Set -- others: -import Class +import GHC.Core.Class import Outputable import Util -import SrcLoc -import Type +import GHC.Types.SrcLoc +import GHC.Core.Type import Bag import Maybes @@ -438,7 +438,7 @@ to ensure correct module and provenance is set These are the two places that we have to conjure up the magic derived -names. (The actual magic is in OccName.mkWorkerOcc, etc.) +names. (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.) Default methods ~~~~~~~~~~~~~~~ @@ -447,7 +447,7 @@ - If there is a default method name at all, it's recorded in the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field. - (DefMethInfo is defined in Class.hs) + (DefMethInfo is defined in GHC.Core.Class) Source-code class decls and interface-code class decls are treated subtly differently, which has given me a great deal of confusion over the years. @@ -631,7 +631,7 @@ own right. However we are careful to use the same name 'a', so that we can match things up. -c.f. Note [Associated type tyvar names] in Class.hs +c.f. Note [Associated type tyvar names] in GHC.Core.Class Note [Family instance declaration binders] -} @@ -898,9 +898,9 @@ * The CUSK completely fixes the kind of the type constructor, forever. - * The precise rules, for each declaration form, for whethher a declaration + * The precise rules, for each declaration form, for whether a declaration has a CUSK are given in the user manual section "Complete user-supplied - kind signatures and polymorphic recursion". BUt they simply implement + kind signatures and polymorphic recursion". But they simply implement PRINCIPLE above. * Open type families are interesting: @@ -1057,7 +1057,7 @@ Here injectivity annotation would consist of two comma-separated injectivity conditions. -See also Note [Injective type families] in TyCon +See also Note [Injective type families] in GHC.Core.TyCon -} -- | Located type Family Result Signature @@ -2241,7 +2241,7 @@ -- | Located Rule Declarations type LRuleDecls pass = Located (RuleDecls pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass , rds_src :: SourceText @@ -2260,7 +2260,7 @@ { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes + -- ^ Note [Pragma source text] in GHC.Types.Basic , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] -- ^ Forall'd type vars @@ -2387,7 +2387,7 @@ -- | Located Warning Declarations type LWarnDecls pass = Located (WarnDecls pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass , wd_src :: SourceText @@ -2437,7 +2437,7 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (AnnProvenance (IdP pass)) (Located (HsExpr pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType' diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -28,9 +28,9 @@ import Binary import Encoding import FastFunctions -import Name +import GHC.Types.Name import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Data.ByteString (ByteString) import qualified Data.ByteString as BS diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -19,16 +19,15 @@ import Data.Data hiding (Fixity) import Bag -import BasicTypes +import GHC.Types.Basic import FastString -import NameSet -import Name -import DataCon -import SrcLoc +import GHC.Types.Name.Set +import GHC.Types.Name +import GHC.Core.DataCon +import GHC.Types.SrcLoc import GHC.Hs -import OccName hiding (occName) -import Var -import Module +import GHC.Types.Var +import GHC.Types.Module import Outputable import qualified Data.ByteString as B @@ -110,7 +109,7 @@ occName n = braces $ text "OccName: " - <> text (OccName.occNameString n) + <> text (occNameString n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName: " <> ppr m diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -38,15 +38,15 @@ -- others: import TcEvidence import GHC.Core -import Name -import NameSet -import BasicTypes -import ConLike -import SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Core.ConLike +import GHC.Types.SrcLoc import Util import Outputable import FastString -import Type +import GHC.Core.Type import TysWiredIn (mkTupleStr) import TcType (TcType) import {-# SOURCE #-} TcRnTypes (TcLclEnv) @@ -55,7 +55,7 @@ import Data.Data hiding (Fixity(..)) import qualified Data.Data as Data (Fixity(..)) import qualified Data.Kind -import Data.Maybe (isNothing) +import Data.Maybe (isJust) import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) @@ -200,7 +200,7 @@ -- See Note [CmdSyntaxTable] {- -Note [CmdSyntaxtable] +Note [CmdSyntaxTable] ~~~~~~~~~~~~~~~~~~~~~ Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps track of the methods needed for a Cmd. @@ -675,7 +675,7 @@ -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic StringLiteral -- "set cost centre" SCC pragma -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, @@ -683,7 +683,7 @@ -- For details on above see note [Api annotations] in ApiAnnotation | HsPragCore (XCoreAnn p) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic StringLiteral -- hdaume: core annotation -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', @@ -698,12 +698,12 @@ -- For details on above see note [Api annotations] in ApiAnnotation | HsPragTick -- A pragma introduced tick (XTickPragma p) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick ((SourceText,SourceText),(SourceText,SourceText)) -- Source text for the four integers used in the span. - -- See note [Pragma source text] in BasicTypes + -- See note [Pragma source text] in GHC.Types.Basic | XHsPragE (XXPragE p) @@ -1089,10 +1089,9 @@ GhcPs -> ppr x GhcRn -> ppr x GhcTc -> case x of - HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e + HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e else pprExpr e) - ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) @@ -1118,7 +1117,7 @@ -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) -- = char '@' <> pprHsType arg pp (Right arg) - = char '@' <> ppr arg + = text "@" <> ppr arg pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) @@ -1712,41 +1711,39 @@ pprMatch :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc -pprMatch match +pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss }) = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) - , nest 2 (pprGRHSs ctxt (m_grhss match)) ] + , nest 2 (pprGRHSs ctxt grhss) ] where - ctxt = m_ctxt match (herald, other_pats) = case ctxt of FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} - | strictness == SrcStrict -> ASSERT(null $ m_pats match) - (char '!'<>pprPrefixOcc fun, m_pats match) - -- a strict variable binding - | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) - -- f x y z = e - -- Not pprBndr; the AbsBinds will - -- have printed the signature - - | null pats2 -> (pp_infix, []) - -- x &&& y = e - - | otherwise -> (parens pp_infix, pats2) - -- (x &&& y) z = e - where - pp_infix = pprParendLPat opPrec pat1 - <+> pprInfixOcc fun - <+> pprParendLPat opPrec pat2 + | SrcStrict <- strictness + -> ASSERT(null pats) -- A strict variable binding + (char '!'<>pprPrefixOcc fun, pats) - LambdaExpr -> (char '\\', m_pats match) + | Prefix <- fixity + -> (pprPrefixOcc fun, pats) -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + | otherwise + -> case pats of + (p1:p2:rest) + | null rest -> (pp_infix, []) -- x &&& y = e + | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e + where + pp_infix = pprParendLPat opPrec p1 + <+> pprInfixOcc fun + <+> pprParendLPat opPrec p2 + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) - _ -> if null (m_pats match) - then (empty, []) - else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) - (ppr pat1, []) -- No parens around the single pat + LambdaExpr -> (char '\\', pats) - (pat1:pats1) = m_pats match - (pat2:pats2) = pats1 + _ -> case pats of + [] -> (empty, []) + [pat] -> (ppr pat, []) -- No parens around the single pat in a case + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) +pprMatch (XMatch nec) = noExtCon nec pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc @@ -1827,7 +1824,10 @@ -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff (XLastStmt idL idR body) body - Bool -- True <=> return was stripped by ApplicativeDo + (Maybe Bool) -- Whether return was stripped + -- Just True <=> return with a dollar was stripped by ApplicativeDo + -- Just False <=> return without a dollar was stripped by ApplicativeDo + -- Nothing <=> Nothing was stripped (SyntaxExpr idR) -- The return operator -- The return operator is used only for MonadComp -- For ListComp we use the baked-in 'return' @@ -2213,10 +2213,13 @@ OutputableBndrId idR, Outputable body) => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc -pprStmt (LastStmt _ expr ret_stripped _) +pprStmt (LastStmt _ expr m_dollar_stripped _) = whenPprDebug (text "[last]") <+> - (if ret_stripped then text "return" else empty) <+> - ppr expr + (case m_dollar_stripped of + Just True -> text "return $" + Just False -> text "return" + Nothing -> empty) <+> + ppr expr pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] pprStmt (BodyStmt _ expr _ _) = ppr expr @@ -2267,27 +2270,35 @@ let ap_expr = sep (punctuate (text " |") (map pp_arg args)) in - if isNothing mb_join - then ap_expr - else text "join" <+> parens ap_expr + whenPprDebug (if isJust mb_join then text "[join]" else empty) <+> + (if lengthAtLeast args 2 then parens else id) ap_expr pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, ApplicativeArgOne _ pat expr isBody _) - | isBody = -- See Note [Applicative BodyStmt] - ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + pp_arg (_, applicativeArg) = ppr applicativeArg + +pprStmt (XStmtLR x) = ppr x + + +instance (OutputableBndrId idL) + => Outputable (ApplicativeArg (GhcPass idL)) where + ppr = pprArg + +pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc +pprArg (ApplicativeArgOne _ pat expr isBody _) + | isBody = -- See Note [Applicative BodyStmt] + ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) - | otherwise = - ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr + | otherwise = + ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) - pp_arg (_, ApplicativeArgMany _ stmts return pat) = +pprArg (ApplicativeArgMany _ stmts return pat) = ppr pat <+> text "<-" <+> ppr (HsDo (panic "pprStmt") DoExpr (noLoc (stmts ++ - [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)]))) - pp_arg (_, XApplicativeArg x) = ppr x + [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]))) -pprStmt (XStmtLR x) = ppr x +pprArg (XApplicativeArg x) = ppr x pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -10,10 +10,10 @@ module GHC.Hs.Expr where -import SrcLoc ( Located ) +import GHC.Types.SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) -import BasicTypes ( SpliceExplicitFlag(..)) +import GHC.Types.Basic ( SpliceExplicitFlag(..)) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) import Data.Kind ( Type ) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -28,11 +28,11 @@ import GhcPrelude import Data.Data hiding ( Fixity ) -import Name -import RdrName -import Var +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Var import Outputable -import SrcLoc (Located) +import GHC.Types.SrcLoc (Located) import Data.Kind diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -18,15 +18,15 @@ import GhcPrelude -import Module ( ModuleName ) -import GHC.Hs.Doc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc ) -import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import FieldLabel ( FieldLbl(..) ) +import GHC.Types.Module ( ModuleName ) +import GHC.Hs.Doc ( HsDocString ) +import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) +import GHC.Types.Basic ( SourceText(..), StringLiteral(..), pprWithSourceText ) +import GHC.Types.FieldLabel ( FieldLbl(..) ) import Outputable import FastString -import SrcLoc +import GHC.Types.SrcLoc import GHC.Hs.Extension import Data.Data @@ -80,7 +80,7 @@ = ImportDecl { ideclExt :: XCImportDecl pass, ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import @@ -282,7 +282,7 @@ IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) -See Note [Representing fields in AvailInfo] in Avail for more details. +See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -} ieName :: IE (GhcPass p) -> IdP (GhcPass p) diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -22,10 +22,11 @@ import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) -import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, - negateFractionalLit,SourceText(..),pprWithSourceText, - PprPrec(..), topPrec ) -import Type +import GHC.Types.Basic + ( IntegralLit(..), FractionalLit(..), negateIntegralLit + , negateFractionalLit, SourceText(..), pprWithSourceText + , PprPrec(..), topPrec ) +import GHC.Core.Type import Outputable import FastString import GHC.Hs.Extension @@ -41,7 +42,7 @@ ************************************************************************ -} --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following -- | Haskell Literal @@ -133,7 +134,7 @@ type instance XXOverLit (GhcPass _) = NoExtCon --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -1,3 +1,4 @@ + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -55,18 +56,19 @@ import GHC.Hs.Extension import GHC.Hs.Types import TcEvidence -import BasicTypes +import GHC.Types.Basic -- others: import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) +import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) import TysWiredIn -import Var -import RdrName ( RdrName ) -import ConLike -import DataCon -import TyCon +import GHC.Types.Var +import GHC.Types.Name.Reader ( RdrName ) +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon import Outputable -import Type -import SrcLoc +import GHC.Core.Type +import GHC.Types.SrcLoc import Bag -- collect ev vars from pats import Maybes -- libraries: @@ -526,10 +528,11 @@ pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] pprPat (SplicePat _ splice) = pprSplice splice pprPat (CoPat _ co pat _) = pprIfTc @p $ - pprHsWrapper co $ \parens - -> if parens - then pprParendPat appPrec pat - else pprPat pat + sdocWithDynFlags $ \ dflags -> + if gopt Opt_PrintTypecheckerElaboration dflags + then hang (text "CoPat" <+> parens (ppr co)) + 2 (pprParendPat appPrec pat) + else pprPat pat pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty where ppr_ty = case ghcPass @p of GhcPs -> ppr ty @@ -734,7 +737,7 @@ -- since we cannot know until the splice is evaluated. go (SplicePat {}) = False - go (XPat {}) = False + go (XPat nec) = noExtCon nec -- | Is the pattern any of combination of: -- diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -78,16 +78,16 @@ import GHC.Hs.Extension -import Id ( Id ) -import Name( Name, NamedThing(getName) ) -import RdrName ( RdrName ) -import DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) +import GHC.Types.Id ( Id ) +import GHC.Types.Name( Name, NamedThing(getName) ) +import GHC.Types.Name.Reader ( RdrName ) +import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..) ) import TysWiredIn( mkTupleStr ) -import Type +import GHC.Core.Type import GHC.Hs.Doc -import BasicTypes -import SrcLoc +import GHC.Types.Basic +import GHC.Types.SrcLoc import Outputable import FastString import Maybes( isJust ) @@ -750,7 +750,7 @@ type instance XXType (GhcPass _) = NewHsTypeX --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Haskell Type Literal data HsTyLit diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -77,7 +77,7 @@ -- * Template Haskell mkUntypedSplice, mkTypedSplice, - mkHsQuasiQuote, unqualQuasiQuote, + mkHsQuasiQuote, -- * Collecting binders isUnliftedHsBind, isBangedHsBind, @@ -110,20 +110,20 @@ import GHC.Hs.Extension import TcEvidence -import RdrName -import Var -import TyCoRep -import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Core.TyCo.Rep +import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) import TysWiredIn ( unitTy ) import TcType -import DataCon -import ConLike -import Id -import Name -import NameSet hiding ( unitFV ) -import NameEnv -import BasicTypes -import SrcLoc +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Set hiding ( unitFV ) +import GHC.Types.Name.Env +import GHC.Types.Basic +import GHC.Types.SrcLoc import FastString import Util import Bag @@ -316,7 +316,7 @@ mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt body = LastStmt noExtField body False noSyntaxExpr +mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr mkBodyStmt body = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr mkBindStmt pat body @@ -367,11 +367,6 @@ mkHsQuasiQuote quoter span quote = HsQuasiQuote noExtField unqualSplice quoter span quote -unqualQuasiQuote :: RdrName -unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) - -- A name (uniquified later) to - -- identify the quasi-quote - mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) @@ -503,8 +498,21 @@ nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) nlHsParTy t = noLoc (HsParTy noExtField t) -nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) -nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys +nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p) + -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp fixity tycon tys + | Infix <- fixity + , HsValArg ty1 : HsValArg ty2 : rest <- tys + = foldl' mk_app (noLoc $ HsOpTy noExtField ty1 (noLoc tycon) ty2) rest + | otherwise + = foldl' mk_app (nlHsTyVar tycon) tys + where + mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) + mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLoc $ HsParTy noExtField fun) arg + -- parenthesize things like `(A + B) C` + mk_app fun (HsValArg ty) = noLoc (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) + mk_app fun (HsTypeArg _ ki) = noLoc (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki)) + mk_app fun (HsArgPar _) = noLoc (HsParTy noExtField fun) nlHsAppKindTy :: LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) @@ -730,9 +738,10 @@ The derived Eq instance for Glurp (without any kind signatures) would be: instance Eq a => Eq (Glurp a) where + (==) :: Glurp a -> Glurp a -> Bool (==) = coerce @(Wat2 P -> Wat2 P -> Bool) @(Glurp a -> Glurp a -> Bool) - (==) :: Glurp a -> Glurp a -> Bool + (==) (Where the visible type applications use types produced by typeToLHsType.) @@ -828,7 +837,7 @@ mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_ext = noExtField, - var_id = var, var_rhs = rhs, var_inline = False } + var_id = var, var_rhs = rhs } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -24,6 +24,10 @@ -- * Caching partially matched COMPLETE sets ConLikeSet, PossibleMatches(..), + -- * PmAltConSet + PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet, + extendPmAltConSet, pmAltConSetElems, + -- * A 'DIdEnv' where entries may be shared Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE, setIndirectSDIE, setEntrySDIE, traverseSDIE, @@ -40,19 +44,20 @@ import Util import Bag import FastString -import Var (EvVar) -import Id -import VarEnv -import UniqDSet -import UniqDFM -import Name -import DataCon -import ConLike +import GHC.Types.Var (EvVar) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM +import GHC.Types.Name +import GHC.Core.DataCon +import GHC.Core.ConLike import Outputable +import ListSetOps (unionLists) import Maybes -import Type -import TyCon -import Literal +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Types.Literal import GHC.Core import GHC.Core.Map import GHC.Core.Utils (exprType) @@ -152,6 +157,33 @@ data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit +data PmAltConSet = PACS !ConLikeSet ![PmLit] + +emptyPmAltConSet :: PmAltConSet +emptyPmAltConSet = PACS emptyUniqDSet [] + +isEmptyPmAltConSet :: PmAltConSet -> Bool +isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits + +-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to +-- the given 'PmAltCon' according to 'eqPmAltCon'. +elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool +elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls +elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits + +extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet +extendPmAltConSet (PACS cls lits) (PmAltConLike cl) + = PACS (addOneToUniqDSet cls cl) lits +extendPmAltConSet (PACS cls lits) (PmAltLit lit) + = PACS cls (unionLists lits [lit]) + +pmAltConSetElems :: PmAltConSet -> [PmAltCon] +pmAltConSetElems (PACS cls lits) + = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits + +instance Outputable PmAltConSet where + ppr = ppr . pmAltConSetElems + -- | We can't in general decide whether two 'PmAltCon's match the same set of -- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a -- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'. @@ -475,7 +507,7 @@ -- However, no more than one RealDataCon in the list, otherwise contradiction -- because of generativity. - , vi_neg :: ![PmAltCon] + , vi_neg :: !PmAltConSet -- ^ Negative info: A list of 'PmAltCon's that it cannot match. -- Example, assuming -- @@ -489,6 +521,9 @@ -- between 'vi_pos' and 'vi_neg'. -- See Note [Why record both positive and negative info?] + -- It's worth having an actual set rather than a simple association list, + -- because files like Cabal's `LicenseId` define relatively huge enums + -- that lead to quadratic or worse behavior. , vi_cache :: !PossibleMatches -- ^ A cache of the associated COMPLETE sets. At any time a superset of diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -47,29 +47,29 @@ import GHC.Iface.Type import BinFingerprint import GHC.Core( IsOrphan, isOrphan ) -import Demand -import Cpr -import Class -import FieldLabel -import NameSet -import CoAxiom ( BranchIndex ) -import Name -import CostCentre -import Literal -import ForeignCall -import Annotations( AnnPayload, AnnTarget ) -import BasicTypes +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Class +import GHC.Types.FieldLabel +import GHC.Types.Name.Set +import GHC.Core.Coercion.Axiom ( BranchIndex ) +import GHC.Types.Name +import GHC.Types.CostCentre +import GHC.Types.Literal +import GHC.Types.ForeignCall +import GHC.Types.Annotations( AnnPayload, AnnTarget ) +import GHC.Types.Basic import Outputable -import Module -import SrcLoc +import GHC.Types.Module +import GHC.Types.SrcLoc import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import Var( VarBndr(..), binderVar ) -import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +import GHC.Types.Var( VarBndr(..), binderVar ) +import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import Util( dropList, filterByList, notNull, unzipWith, debugIsOn ) -import DataCon (SrcStrictness(..), SrcUnpackedness(..)) -import Lexeme (isLexSym) +import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import GHC.Utils.Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) import Util (seqList) @@ -222,7 +222,7 @@ , ifaxbRoles :: [Role] , ifaxbRHS :: IfaceType , ifaxbIncomps :: [BranchIndex] } - -- See Note [Storing compatibility] in CoAxiom + -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom data IfaceConDecls = IfAbstractTyCon -- c.f TyCon.AbstractTyCon @@ -254,7 +254,7 @@ -- set of tyvars (*not* covars) of ifConExTCvs, unioned -- with the set of ifBinders (from the parent IfaceDecl) -- whose tyvars do not appear in ifConEqSpec - -- See Note [DataCon user type variable binders] in DataCon + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types @@ -262,7 +262,7 @@ ifConStricts :: [IfaceBang], -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys - -- See Note [Bangs on imported data constructors] in MkId + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts type IfaceEqSpec = [(IfLclName,IfaceType)] @@ -281,7 +281,7 @@ ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst ifDFun :: IfExtName, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv + ifInstOrph :: IsOrphan } -- See Note [Orphans] in GHC.Core.InstEnv -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -777,7 +777,7 @@ then isIfaceTauType kind -- Even in the presence of a standalone kind signature, a non-tau -- result kind annotation cannot be discarded as it determines the arity. - -- See Note [Arity inference in kcDeclHeader_sig] in TcHsType + -- See Note [Arity inference in kcCheckDeclHeader_sig] in TcHsType else isIfaceLiftedTypeKind kind) (dcolon <+> ppr kind) @@ -1200,7 +1200,7 @@ -- 3. Pretty-print the data type constructor applied to its arguments. -- This process will omit any invisible arguments, such as coercion -- variables, if necessary. (See Note - -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) + -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) ppr_tc_app gadt_subst = pprPrefixIfDeclBndr how_much (occName tycon) <+> pprParendIfaceAppArgs @@ -1280,7 +1280,7 @@ pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens --- | Pretty Print an IfaceExpre +-- | Pretty Print an IfaceExpr -- -- The first argument should be a function that adds parens in context that need -- an atomic value (e.g. function args) @@ -1417,7 +1417,7 @@ * * ************************************************************************ -This is used for dependency analysis in GHC.Iface.Utils, so that we +This is used for dependency analysis in GHC.Iface.Make, so that we fingerprint a declaration before the things that depend on it. It is specific to interface-file fingerprinting in the sense that we don't collect *all* Names: for example, the DFun of an instance is diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -64,14 +64,14 @@ import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon , liftedRepDataConTyCon, tupleTyConName ) -import {-# SOURCE #-} Type ( isRuntimeRepTy ) +import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy ) -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom -import Var +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Var import PrelNames -import Name -import BasicTypes +import GHC.Types.Name +import GHC.Types.Basic import Binary import Outputable import FastString @@ -119,7 +119,7 @@ type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy - = IfaceNoOneShot -- and Note [The oneShot function] in MkId + = IfaceNoOneShot -- and Note [The oneShot function] in GHC.Types.Id.Make | IfaceOneShot @@ -567,7 +567,7 @@ -- Keep recursing through the remainder of the arguments, as it's -- possible that there are remaining invisible ones. -- See the "In type declarations" section of Note [VarBndrs, - -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. + -- TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. | otherwise -> suppress_invis ts @@ -675,7 +675,7 @@ Here, @{k} indicates that `k` is an inferred argument, and @k indicates that `k` is a specified argument. (See -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for a lengthier explanation on what "inferred" and "specified" mean.) ************************************************************************ @@ -776,7 +776,7 @@ case vis of AnonTCB VisArg -> ppr_bndr (UseBndrParens True) AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.) + -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) -- Should we print these differently? NamedTCB Required -> ppr_bndr (UseBndrParens True) NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) @@ -922,10 +922,10 @@ (forall a. blah) Conclusion: keep track of whether we we are in the kind of a -binder; ohly if so, convert free RuntimeRep variables to LiftedRep. +binder; only if so, convert free RuntimeRep variables to LiftedRep. -} --- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. +-- | Default 'RuntimeRep' variables to 'LiftedRep'. e.g. -- -- @ -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). @@ -967,7 +967,7 @@ go in_kind _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars - | in_kind && Type.isRuntimeRepTy (tyVarKind tv) + | in_kind && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) = IfaceTyConApp liftedRep IA_Nil | otherwise = ty @@ -1175,7 +1175,7 @@ utterly misleading. See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] - in TyCoRep. + in GHC.Core.TyCo.Rep. N.B. Until now (Aug 2018) we didn't check anything for coercion variables. @@ -1252,7 +1252,7 @@ pprSpaceIfPromotedTyCon _ = id --- See equivalent function in TyCoRep.hs +-- See equivalent function in GHC.Core.TyCo.Rep.hs pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print -- it in list notation [t1, ...]. @@ -1462,7 +1462,7 @@ pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc pprSum _arity is_promoted args = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon let tys = appArgsIfaceTypes args args' = drop (length tys `div` 2) tys in pprPromotionQuoteI is_promoted @@ -1489,7 +1489,7 @@ | otherwise -> -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon let tys = appArgsIfaceTypes args args' = case sort of UnboxedTuple -> drop (length tys `div` 2) tys diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot --- a/compiler/GHC/Iface/Type.hs-boot +++ b/compiler/GHC/Iface/Type.hs-boot @@ -4,7 +4,7 @@ ) where -import Var (VarBndr, ArgFlag) +import GHC.Types.Var (VarBndr, ArgFlag) data IfaceAppArgs diff --git a/compiler/GHC/Platform/Reg.hs b/compiler/GHC/Platform/Reg.hs --- a/compiler/GHC/Platform/Reg.hs +++ b/compiler/GHC/Platform/Reg.hs @@ -29,7 +29,7 @@ import GhcPrelude import Outputable -import Unique +import GHC.Types.Unique import GHC.Platform.Reg.Class import Data.List (intersect) diff --git a/compiler/GHC/Platform/Reg/Class.hs b/compiler/GHC/Platform/Reg/Class.hs --- a/compiler/GHC/Platform/Reg/Class.hs +++ b/compiler/GHC/Platform/Reg/Class.hs @@ -6,8 +6,8 @@ import GhcPrelude -import Outputable -import Unique +import Outputable +import GHC.Types.Unique -- | The class of a register. diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs --- a/compiler/GHC/Runtime/Eval/Types.hs +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -16,12 +16,12 @@ import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) -import Id -import Name -import Module -import RdrName -import Type -import SrcLoc +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Module +import GHC.Types.Name.Reader +import GHC.Core.Type +import GHC.Types.SrcLoc import Exception import Data.Word diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -46,7 +46,7 @@ import GhcPrelude -import BasicTypes( ConTagZ ) +import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session import Outputable import GHC.Platform @@ -72,8 +72,8 @@ -- | Round up the given byte count to the next byte count that's a -- multiple of the machine's word size. -roundUpToWords :: DynFlags -> ByteOff -> ByteOff -roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags) +roundUpToWords :: Platform -> ByteOff -> ByteOff +roundUpToWords platform n = roundUpTo n (platformWordSizeInBytes platform) -- | Round up @base@ to a multiple of @size@. roundUpTo :: ByteOff -> ByteOff -> ByteOff @@ -83,17 +83,17 @@ -- -- This function morally has type @WordOff -> ByteOff@, but uses @Num -- a@ to allow for overloading. -wordsToBytes :: Num a => DynFlags -> a -> a -wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n -{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} +wordsToBytes :: Num a => Platform -> a -> a +wordsToBytes platform n = fromIntegral (platformWordSizeInBytes platform) * n +{-# SPECIALIZE wordsToBytes :: Platform -> Int -> Int #-} +{-# SPECIALIZE wordsToBytes :: Platform -> Word -> Word #-} +{-# SPECIALIZE wordsToBytes :: Platform -> Integer -> Integer #-} -- | First round the given byte count up to a multiple of the -- machine's word size and then convert the result to words. -bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff -bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size - where word_size = wORD_SIZE dflags +bytesToWordsRoundUp :: Platform -> ByteOff -> WordOff +bytesToWordsRoundUp platform n = (n + word_size - 1) `quot` word_size + where word_size = platformWordSizeInBytes platform -- StgWord is a type representing an StgWord on the target platform. -- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform newtype StgWord = StgWord Word64 @@ -102,9 +102,9 @@ fromStgWord :: StgWord -> Integer fromStgWord (StgWord i) = toInteger i -toStgWord :: DynFlags -> Integer -> StgWord -toStgWord dflags i - = case platformWordSize (targetPlatform dflags) of +toStgWord :: Platform -> Integer -> StgWord +toStgWord platform i + = case platformWordSize platform of -- These conversions mean that things like toStgWord (-1) -- do the right thing PW4 -> StgWord (fromIntegral (fromInteger i :: Word32)) @@ -123,9 +123,9 @@ fromStgHalfWord :: StgHalfWord -> Integer fromStgHalfWord (StgHalfWord w) = toInteger w -toStgHalfWord :: DynFlags -> Integer -> StgHalfWord -toStgHalfWord dflags i - = case platformWordSize (targetPlatform dflags) of +toStgHalfWord :: Platform -> Integer -> StgHalfWord +toStgHalfWord platform i + = case platformWordSize platform of -- These conversions mean that things like toStgHalfWord (-1) -- do the right thing PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) @@ -135,11 +135,11 @@ ppr (StgHalfWord w) = integer (toInteger w) -- | Half word size in bytes -halfWordSize :: DynFlags -> ByteOff -halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2 +halfWordSize :: Platform -> ByteOff +halfWordSize platform = platformWordSizeInBytes platform `div` 2 -halfWordSizeInBits :: DynFlags -> Int -halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2 +halfWordSizeInBits :: Platform -> Int +halfWordSizeInBits platform = platformWordSizeInBits platform `div` 2 {- ************************************************************************ @@ -255,8 +255,8 @@ smallArrPtrsRep :: WordOff -> SMRep smallArrPtrsRep elems = SmallArrayPtrsRep elems -arrWordsRep :: DynFlags -> ByteOff -> SMRep -arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) +arrWordsRep :: Platform -> ByteOff -> SMRep +arrWordsRep platform bytes = ArrayWordsRep (bytesToWordsRoundUp platform bytes) ----------------------------------------------------------------------------- -- Predicates @@ -297,7 +297,7 @@ -- Size-related things fixedHdrSize :: DynFlags -> ByteOff -fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags) +fixedHdrSize dflags = wordsToBytes (targetPlatform dflags) (fixedHdrSizeW dflags) -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) fixedHdrSizeW :: DynFlags -> WordOff @@ -322,7 +322,8 @@ arrWordsHdrSizeW :: DynFlags -> WordOff arrWordsHdrSizeW dflags = fixedHdrSizeW dflags + - (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags) + (sIZEOF_StgArrBytes_NoHdr dflags `quot` + platformWordSizeInBytes (targetPlatform dflags)) arrPtrsHdrSize :: DynFlags -> ByteOff arrPtrsHdrSize dflags @@ -331,7 +332,8 @@ arrPtrsHdrSizeW :: DynFlags -> WordOff arrPtrsHdrSizeW dflags = fixedHdrSizeW dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) + (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` + platformWordSizeInBytes (targetPlatform dflags)) smallArrPtrsHdrSize :: DynFlags -> ByteOff smallArrPtrsHdrSize dflags @@ -340,16 +342,18 @@ smallArrPtrsHdrSizeW :: DynFlags -> WordOff smallArrPtrsHdrSizeW dflags = fixedHdrSizeW dflags + - (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) + (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` + platformWordSizeInBytes (targetPlatform dflags)) -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. thunkHdrSize :: DynFlags -> WordOff thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags + where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` + platformWordSizeInBytes (targetPlatform dflags) hdrSize :: DynFlags -> SMRep -> ByteOff -hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep) +hdrSize dflags rep = wordsToBytes (targetPlatform dflags) (hdrSizeW dflags rep) hdrSizeW :: DynFlags -> SMRep -> WordOff hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty @@ -358,8 +362,8 @@ hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags hdrSizeW _ _ = panic "SMRep.hdrSizeW" -nonHdrSize :: DynFlags -> SMRep -> ByteOff -nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) +nonHdrSize :: Platform -> SMRep -> ByteOff +nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep) nonHdrSizeW :: SMRep -> WordOff nonHdrSizeW (HeapRep _ p np _) = p + np @@ -413,7 +417,8 @@ -- | The size of a card table, in words cardTableSizeW :: DynFlags -> Int -> WordOff cardTableSizeW dflags elems = - bytesToWordsRoundUp dflags (cardTableSizeB dflags elems) + bytesToWordsRoundUp (targetPlatform dflags) + (cardTableSizeB dflags elems) ----------------------------------------------------------------------------- -- deriving the RTS closure type from an SMRep diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs --- a/compiler/GHC/Runtime/Interpreter/Types.hs +++ b/compiler/GHC/Runtime/Interpreter/Types.hs @@ -14,7 +14,7 @@ import GHCi.RemoteTypes import GHCi.Message ( Pipe ) -import UniqFM +import GHC.Types.Unique.FM import Foreign import Control.Concurrent @@ -22,9 +22,9 @@ -- | Runtime interpreter data Interp - = ExternalInterp !IServ -- ^ External interpreter + = ExternalInterp !IServConfig !IServ -- ^ External interpreter #if defined(HAVE_INTERNAL_INTERPRETER) - | InternalInterp -- ^ Internal interpreter + | InternalInterp -- ^ Internal interpreter #endif -- | External interpreter @@ -36,15 +36,17 @@ -- | State of an external interpreter data IServState - = IServPending !IServConfig -- ^ Not spawned yet + = IServPending -- ^ Not spawned yet | IServRunning !IServInstance -- ^ Running -- | Configuration needed to spawn an external interpreter data IServConfig = IServConfig - { iservConfProgram :: !String -- ^ External program to run - , iservConfOpts :: ![String] -- ^ Command-line options - , iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook - , iservConfTrace :: IO () -- ^ Trace action executed after spawn + { iservConfProgram :: !String -- ^ External program to run + , iservConfOpts :: ![String] -- ^ Command-line options + , iservConfProfiled :: !Bool -- ^ Use Profiling way + , iservConfDynamic :: !Bool -- ^ Use Dynamic way + , iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook + , iservConfTrace :: IO () -- ^ Trace action executed after spawn } -- | External interpreter instance @@ -56,8 +58,5 @@ -- ^ Values that need to be freed before the next command is sent. -- Threads can append values to this list asynchronously (by modifying the -- IServ state MVar). - - , iservConfig :: !IServConfig - -- ^ Config used to spawn the external interpreter } diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs --- a/compiler/GHC/Runtime/Linker/Types.hs +++ b/compiler/GHC/Runtime/Linker/Types.hs @@ -19,13 +19,13 @@ import Data.Time ( UTCTime ) import Data.Maybe ( Maybe ) import Control.Concurrent.MVar ( MVar ) -import Module ( InstalledUnitId, Module ) -import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) +import GHC.Types.Module ( InstalledUnitId, Module ) +import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) import Outputable -import Var ( Id ) +import GHC.Types.Var ( Id ) import GHC.Fingerprint.Type ( Fingerprint ) -import NameEnv ( NameEnv ) -import Name ( Name ) +import GHC.Types.Name.Env ( NameEnv ) +import GHC.Types.Name ( Name ) import GHCi.RemoteTypes ( ForeignHValue ) type ClosureEnv = NameEnv (Name, ForeignHValue) diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -64,25 +64,25 @@ import GhcPrelude import GHC.Core ( AltCon, Tickish ) -import CostCentre ( CostCentreStack ) +import GHC.Types.CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) import Data.Data ( Data ) import Data.List ( intersperse ) -import DataCon +import GHC.Core.DataCon import GHC.Driver.Session -import ForeignCall ( ForeignCall ) -import Id -import VarSet -import Literal ( Literal, literalType ) -import Module ( Module ) +import GHC.Types.ForeignCall ( ForeignCall ) +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Literal ( Literal, literalType ) +import GHC.Types.Module ( Module ) import Outputable -import GHC.Driver.Packages ( isDllName ) +import GHC.Driver.Packages ( isDynLinkName ) import GHC.Platform import GHC.Core.Ppr( {- instances -} ) -import PrimOp ( PrimOp, PrimCall ) -import TyCon ( PrimRep(..), TyCon ) -import Type ( Type ) -import GHC.Types.RepType ( typePrimRep1 ) +import PrimOp ( PrimOp, PrimCall ) +import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.Type ( Type ) +import GHC.Types.RepType ( typePrimRep1 ) import Util import Data.List.NonEmpty ( NonEmpty, toList ) @@ -127,14 +127,14 @@ isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool isDllConApp dflags this_mod con args | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName dflags this_mod (dataConName con) || any is_dll_arg args + = isDynLinkName dflags this_mod (dataConName con) || any is_dll_arg args | otherwise = False where -- NB: typePrimRep1 is legit because any free variables won't have -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) - && isDllName dflags this_mod (idName v) + && isDynLinkName dflags this_mod (idName v) is_dll_arg _ = False -- True of machine addresses; these are the things that don't work across DLLs. diff --git a/compiler/GHC/Types/Annotations.hs b/compiler/GHC/Types/Annotations.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Annotations.hs @@ -0,0 +1,142 @@ +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +{-# LANGUAGE DeriveFunctor #-} +module GHC.Types.Annotations ( + -- * Main Annotation data types + Annotation(..), AnnPayload, + AnnTarget(..), CoreAnnTarget, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, + findAnns, findAnnsByTypeRep, + deserializeAnns + ) where + +import GhcPrelude + +import Binary +import GHC.Types.Module ( Module + , ModuleEnv, emptyModuleEnv, extendModuleEnvWith + , plusModuleEnv_C, lookupWithDefaultModuleEnv + , mapModuleEnv ) +import GHC.Types.Name.Env +import GHC.Types.Name +import Outputable +import GHC.Serialized + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Word ( Word8 ) + + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'HsDecls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: AnnPayload + } + +type AnnPayload = Serialized -- ^ The "payload" of an annotation + -- allows recovery of its value at a given type, + -- and can be persisted to an interface file + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + deriving (Functor) + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) + +-- | A collection of annotations +data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) + , ann_name_env :: !(NameEnv [AnnPayload]) + } + +-- | An empty annotation environment. +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv + +-- | Construct a new annotation environment that contains the list of +-- annotations provided. +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +-- | Add the given annotation to the environment. +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList env = + foldl' extendAnnEnv env + +extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv +extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = + case tgt of + NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) + ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env + +-- | Union two annotation environments. +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv a b = + MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) + , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) + } + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize env + = mapMaybe (fromSerialized deserialize) . findAnnPayloads env + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep env target tyrep + = [ ws | Serialized tyrep' ws <- findAnnPayloads env target + , tyrep' == tyrep ] + +-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. +findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] +findAnnPayloads env target = + case target of + ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod + NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) +deserializeAnns deserialize env + = ( mapModuleEnv deserAnns (ann_mod_env env) + , mapNameEnv deserAnns (ann_name_env env) + ) + where deserAnns = mapMaybe (fromSerialized deserialize) + diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Avail.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- (c) The University of Glasgow +-- + +#include "HsVersions.h" + +module GHC.Types.Avail ( + Avails, + AvailInfo(..), + avail, + availsToNameSet, + availsToNameSetWithSelectors, + availsToNameEnv, + availName, availNames, availNonFldNames, + availNamesWithSelectors, + availFlds, + availsNamesWithOccs, + availNamesWithOccs, + stableAvailCmp, + plusAvail, + trimAvail, + filterAvail, + filterAvails, + nubAvails + + + ) where + +import GhcPrelude + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set + +import GHC.Types.FieldLabel +import Binary +import ListSetOps +import Outputable +import Util + +import Data.Data ( Data ) +import Data.List ( find ) +import Data.Function + +-- ----------------------------------------------------------------------------- +-- The AvailInfo type + +-- | Records what things are \"available\", i.e. in scope +data AvailInfo + + -- | An ordinary identifier in scope + = Avail Name + + -- | A type or class in scope + -- + -- The __AvailTC Invariant__: If the type or class is itself to be in scope, + -- it must be /first/ in this list. Thus, typically: + -- + -- > AvailTC Eq [Eq, ==, \/=] [] + | AvailTC + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class, + -- excluding field selectors. + [FieldLabel] -- ^ The record fields of the type + -- (see Note [Representing fields in AvailInfo]). + + deriving ( Eq -- ^ Used when deciding if the interface has changed + , Data ) + +-- | A collection of 'AvailInfo' - several things that are \"available\" +type Avails = [AvailInfo] + +{- +Note [Representing fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XDuplicateRecordFields is disabled (the normal case), a +datatype like + + data T = MkT { foo :: Int } + +gives rise to the AvailInfo + + AvailTC T [T, MkT] [FieldLabel "foo" False foo] + +whereas if -XDuplicateRecordFields is enabled it gives + + AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] + +since the label does not match the selector name. + +The labels in a field list are not necessarily unique: +data families allow the same parent (the family tycon) to have +multiple distinct fields with the same label. For example, + + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool} + +gives rise to + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" True $sel:foo:MkFBool ] + +Moreover, note that the flIsOverloaded flag need not be the same for +all the elements of the list. In the example above, this occurs if +the two data instances are defined in different modules, one with +`-XDuplicateRecordFields` enabled and one with it disabled. Thus it +is possible to have + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" False foo ] + +If the two data instances are defined in different modules, both +without `-XDuplicateRecordFields`, it will be impossible to export +them from the same module (even with `-XDuplicateRecordfields` +enabled), because they would be represented identically. The +workaround here is to enable `-XDuplicateRecordFields` on the defining +modules. +-} + +-- | Compare lexicographically +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = + (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) `thenCmp` + (cmpList (stableNameCmp `on` flSelector) nfs mfs) +stableAvailCmp (AvailTC {}) (Avail {}) = GT + +avail :: Name -> AvailInfo +avail n = Avail n + +-- ----------------------------------------------------------------------------- +-- Operations on AvailInfo + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNames avail) + +availsToNameSetWithSelectors :: [AvailInfo] -> NameSet +availsToNameSetWithSelectors avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNamesWithSelectors avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) + +-- | Just the main name made available, i.e. not the available pieces +-- of type or class brought into scope by the 'GenAvailInfo' +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _ _) = n + +-- | All names made available by the availability information (excluding overloaded selectors) +availNames :: AvailInfo -> [Name] +availNames (Avail n) = [n] +availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] + +-- | All names made available by the availability information (including overloaded selectors) +availNamesWithSelectors :: AvailInfo -> [Name] +availNamesWithSelectors (Avail n) = [n] +availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs + +-- | Names for non-fields made available by the availability information +availNonFldNames :: AvailInfo -> [Name] +availNonFldNames (Avail n) = [n] +availNonFldNames (AvailTC _ ns _) = ns + +-- | Fields made available by the availability information +availFlds :: AvailInfo -> [FieldLabel] +availFlds (AvailTC _ _ fs) = fs +availFlds _ = [] + +availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] +availsNamesWithOccs = concatMap availNamesWithOccs + +-- | 'Name's made available by the availability information, paired with +-- the 'OccName' used to refer to each one. +-- +-- When @DuplicateRecordFields@ is in use, the 'Name' may be the +-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the +-- 'OccName' will be the label of the field (e.g. @foo@). +-- +-- See Note [Representing fields in AvailInfo]. +availNamesWithOccs :: AvailInfo -> [(Name, OccName)] +availNamesWithOccs (Avail n) = [(n, nameOccName n)] +availNamesWithOccs (AvailTC _ ns fs) + = [ (n, nameOccName n) | n <- ns ] ++ + [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] + +-- ----------------------------------------------------------------------------- +-- Utility + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 +plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (fs1 `unionLists` fs2) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (fs1 `unionLists` fs2) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (fs1 `unionLists` fs2) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) + = AvailTC n1 ss1 (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) + = AvailTC n1 ss2 (fs1 `unionLists` fs2) +plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) + +-- | trims an 'AvailInfo' to keep only a single name +trimAvail :: AvailInfo -> Name -> AvailInfo +trimAvail (Avail n) _ = Avail n +trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of + Just x -> AvailTC n [] [x] + Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail n | keep n -> ie : rest + | otherwise -> rest + AvailTC tc ns fs -> + let ns' = filter keep ns + fs' = filter (keep . flSelector) fs in + if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest + + +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; addAvail does that +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail + +-- ----------------------------------------------------------------------------- +-- Printing + +instance Outputable AvailInfo where + ppr = pprAvail + +pprAvail :: AvailInfo -> SDoc +pprAvail (Avail n) + = ppr n +pprAvail (AvailTC n ns fs) + = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi + , fsep (punctuate comma (map (ppr . flLabel) fs))]) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac ad) = do + putByte bh 1 + put_ bh ab + put_ bh ac + put_ bh ad + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + ad <- get bh + return (AvailTC ab ac ad) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Basic.hs @@ -0,0 +1,1736 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellaneous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Basic ( + Version, bumpVersion, initialVersion, + + LeftOrRight(..), + pickLR, + + ConTag, ConTagZ, fIRST_TAG, + + Arity, RepArity, JoinArity, + + Alignment, mkAlignment, alignmentOf, alignmentBytes, + + PromotionFlag(..), isPromoted, + FunctionOrData(..), + + WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, minPrecedence, + negateFixity, funTyFixity, + compareFixity, + LexicalFixity(..), + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, + + RuleName, pprRuleName, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, + + Boxity(..), isBoxed, + + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, + maybeParen, + + TupleSort(..), tupleSortBoxity, boxityTupleSort, + tupleParens, + + sumParens, pprAlternative, + + -- ** The OneShotInfo type + OneShotInfo(..), + noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, + bestOneShot, worstOneShot, + + OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, + strongLoopBreaker, weakLoopBreaker, + + InsideLam(..), + OneBranch(..), + InterestingCxt(..), + TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, + isAlwaysTailCalled, + + EP(..), + + DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, isSwapped, + + CompilerPhase(..), PhaseNum, + + Activation(..), isActive, isActiveIn, competesWith, + isNeverActive, isAlwaysActive, isEarlyActive, + activeAfterInitial, activeDuringFinal, + + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), noUserInlineSpec, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + pprInline, pprInlineDebug, + + SuccessFlag(..), succeeded, failed, successIf, + + IntegralLit(..), FractionalLit(..), + negateIntegralLit, negateFractionalLit, + mkIntegralLit, mkFractionalLit, + integralFractionalLit, + + SourceText(..), pprWithSourceText, + + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, + + SpliceExplicitFlag(..), + + TypeOrKind(..), isTypeLevel, isKindLevel + ) where + +import GhcPrelude + +import FastString +import Outputable +import GHC.Types.SrcLoc ( Located,unLoc ) +import Data.Data hiding (Fixity, Prefix, Infix) +import Data.Function (on) +import Data.Bits +import qualified Data.Semigroup as Semi + +{- +************************************************************************ +* * + Binary choice +* * +************************************************************************ +-} + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +instance Outputable LeftOrRight where + ppr CLeft = text "Left" + ppr CRight = text "Right" + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +-- See also Note [Definition of arity] in GHC.Core.Arity +type Arity = Int + +-- | Representation Arity +-- +-- The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +-- | The number of arguments that a join point takes. Unlike the arity of a +-- function, this is a purely syntactic property and is fixed when the join +-- point is created (or converted from a value). Both type and value arguments +-- are counted. +type JoinArity = Int + +{- +************************************************************************ +* * + Constructor tags +* * +************************************************************************ +-} + +-- | Constructor Tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +-- | A *zero-indexed* constructor tag +type ConTagZ = Int + +fIRST_TAG :: ConTag +-- ^ Tags are allocated from here for real constructors +-- or for superclass selectors +fIRST_TAG = 1 + +{- +************************************************************************ +* * +\subsection[Alignment]{Alignment} +* * +************************************************************************ +-} + +-- | A power-of-two alignment +newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) + +-- Builds an alignment, throws on non power of 2 input. This is not +-- ideal, but convenient for internal use and better then silently +-- passing incorrect data. +mkAlignment :: Int -> Alignment +mkAlignment n + | n == 1 = Alignment 1 + | n == 2 = Alignment 2 + | n == 4 = Alignment 4 + | n == 8 = Alignment 8 + | n == 16 = Alignment 16 + | n == 32 = Alignment 32 + | n == 64 = Alignment 64 + | n == 128 = Alignment 128 + | n == 256 = Alignment 256 + | n == 512 = Alignment 512 + | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" + +-- Calculates an alignment of a number. x is aligned at N bytes means +-- the remainder from x / N is zero. Currently, interested in N <= 8, +-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX +-- context. +alignmentOf :: Int -> Alignment +alignmentOf x = case x .&. 7 of + 0 -> Alignment 8 + 4 -> Alignment 4 + 2 -> Alignment 2 + _ -> Alignment 1 + +instance Outputable Alignment where + ppr (Alignment m) = ppr m +{- +************************************************************************ +* * + One-shot information +* * +************************************************************************ +-} + +-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound +-- variable info. Sometimes we know whether the lambda binding this variable +-- is a \"one-shot\" lambda; that is, whether it is applied at most once. +-- +-- This information may be useful in optimisation, as computations may +-- safely be floated inside such a lambda without risk of duplicating +-- work. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | OneShotLam -- ^ The lambda is applied at most once. + deriving (Eq) + +-- | It is always safe to assume that an 'Id' has no lambda-bound variable information +noOneShotInfo :: OneShotInfo +noOneShotInfo = NoOneShotInfo + +isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool +isOneShotInfo OneShotLam = True +isOneShotInfo _ = False + +hasNoOneShotInfo NoOneShotInfo = True +hasNoOneShotInfo _ = False + +worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo +worstOneShot NoOneShotInfo _ = NoOneShotInfo +worstOneShot OneShotLam os = os + +bestOneShot NoOneShotInfo os = os +bestOneShot OneShotLam _ = OneShotLam + +pprOneShotInfo :: OneShotInfo -> SDoc +pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo OneShotLam = text "OneShot" + +instance Outputable OneShotInfo where + ppr = pprOneShotInfo + +{- +************************************************************************ +* * + Swap flag +* * +************************************************************************ +-} + +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = text "Is-swapped" + ppr NotSwapped = text "Not-swapped" + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +isSwapped :: SwapFlag -> Bool +isSwapped IsSwapped = True +isSwapped NotSwapped = False + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a + + +{- ********************************************************************* +* * + Promotion flag +* * +********************************************************************* -} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + +instance Outputable PromotionFlag where + ppr NotPromoted = text "NotPromoted" + ppr IsPromoted = text "IsPromoted" + +{- +************************************************************************ +* * +\subsection[FunctionOrData]{FunctionOrData} +* * +************************************************************************ +-} + +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord, Data) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" + +{- +************************************************************************ +* * +\subsection[Version]{Module and identifier version numbers} +* * +************************************************************************ +-} + +type Version = Int + +bumpVersion :: Version -> Version +bumpVersion v = v+1 + +initialVersion :: Version +initialVersion = 1 + +{- +************************************************************************ +* * + Deprecations +* * +************************************************************************ +-} + +-- | A String Literal in the source, including its original raw format for use by +-- source to source manipulation tools. +data StringLiteral = StringLiteral + { sl_st :: SourceText, -- literal raw source. + -- See not [Literal source text] + sl_fs :: FastString -- literal string value + } deriving Data + +instance Eq StringLiteral where + (StringLiteral _ a) == (StringLiteral _ b) = a == b + +instance Outputable StringLiteral where + ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt = WarningTxt (Located SourceText) + [Located StringLiteral] + | DeprecatedTxt (Located SourceText) + [Located StringLiteral] + deriving (Eq, Data) + +instance Outputable WarningTxt where + ppr (WarningTxt lsrc ws) + = case unLoc lsrc of + NoSourceText -> pp_ws ws + SourceText src -> text src <+> pp_ws ws <+> text "#-}" + + ppr (DeprecatedTxt lsrc ds) + = case unLoc lsrc of + NoSourceText -> pp_ws ds + SourceText src -> text src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [Located StringLiteral] -> SDoc +pp_ws [l] = ppr $ unLoc l +pp_ws ws + = text "[" + <+> vcat (punctuate comma (map (ppr . unLoc) ws)) + <+> text "]" + + +pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg (WarningTxt _ ws) + = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) +pprWarningTxtForMsg (DeprecatedTxt _ ds) + = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +pprRuleName :: RuleName -> SDoc +pprRuleName rn = doubleQuotes (ftext rn) + +{- +************************************************************************ +* * +\subsection[Fixity]{Fixity info} +* * +************************************************************************ +-} + +------------------------ +data Fixity = Fixity SourceText Int FixityDirection + -- Note [Pragma source text] + deriving Data + +instance Outputable Fixity where + ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +data FixityDirection = InfixL | InfixR | InfixN + deriving (Eq, Data) + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +------------------------ +maxPrecedence, minPrecedence :: Int +maxPrecedence = 9 +minPrecedence = 0 + +defaultFixity :: Fixity +defaultFixity = Fixity NoSourceText maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 + +{- +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange application, or +whether there's an error. +-} + +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) + +-- |Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Data,Eq) + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = text "" + ppr NotTopLevel = text "" + +{- +************************************************************************ +* * + Boxity flag +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" + +{- +************************************************************************ +* * + Recursive/Non-Recursive flag +* * +************************************************************************ +-} + +-- | Recursivity Flag +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False + +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = text "Recursive" + ppr NonRecursive = text "NonRecursive" + +{- +************************************************************************ +* * + Code origin +* * +************************************************************************ +-} + +data Origin = FromSource + | Generated + deriving( Eq, Data ) + +isGenerated :: Origin -> Bool +isGenerated Generated = True +isGenerated FromSource = False + +instance Outputable Origin where + ppr FromSource = text "FromSource" + ppr Generated = text "Generated" + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a +-- explanation of the `isSafeOverlap` field. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or +-- @'\{-\# OVERLAPPING'@ or +-- @'\{-\# OVERLAPS'@ or +-- @'\{-\# INCOHERENT'@, +-- 'ApiAnnotation.AnnClose' @`\#-\}`@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasIncoherentFlag :: OverlapMode -> Bool +hasIncoherentFlag mode = + case mode of + Incoherent _ -> True + _ -> False + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap SourceText + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps SourceText + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent SourceText + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in GHC.Core.InstEnv + + deriving (Eq, Data) + + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = text "[safe]" +pprSafeOverlap False = empty + +{- +************************************************************************ +* * + Precedence +* * +************************************************************************ +-} + +-- | A general-purpose pretty-printing precedence type. +newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) +-- See Note [Precedence in types] + +topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator +starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) + -- See Note [Star kind precedence] +appPrec = PprPrec 4 -- Constructor args; no parens for atomic + +maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +{- Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many pretty-printing functions have type + ppr_ty :: PprPrec -> Type -> SDoc + +The PprPrec gives the binding strength of the context. For example, in + T ty1 ty2 +we will pretty-print 'ty1' and 'ty2' with the call + (ppr_ty appPrec ty) +to indicate that the context is that of an argument of a TyConApp. + +We use this consistently for Type and HsType. + +Note [Type operator precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the +pretty printer follows the following precedence order: + + TyConPrec Type constructor application + TyOpPrec/FunPrec Operator application and function arrow + +We have funPrec and opPrec to represent the precedence of function +arrow and type operators respectively, but currently we implement +funPrec == opPrec, so that we don't distinguish the two. Reason: +it's hard to parse a type like + a ~ b => c * d -> e - f + +By treating opPrec = funPrec we end up with more parens + (a ~ b) => (c * d) -> (e - f) + +But the two are different constructors of PprPrec so we could make +(->) bind more or less tightly if we wanted. + +Note [Star kind precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We parenthesize the (*) kind to avoid two issues: + +1. Printing invalid or incorrect code. + For example, instead of type F @(*) x = x + GHC used to print type F @* x = x + However, (@*) is a type operator, not a kind application. + +2. Printing kinds that are correct but hard to read. + Should Either * Int be read as Either (*) Int + or as (*) Either Int ? + This depends on whether -XStarIsType is enabled, but it would be + easier if we didn't have to check for the flag when reading the code. + +At the same time, we cannot parenthesize (*) blindly. +Consider this Haskell98 kind: ((* -> *) -> *) -> * +With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*) + +The solution is to assign a special precedence to (*), 'starPrec', which is +higher than 'funPrec' but lower than 'appPrec': + + F * * * becomes F (*) (*) (*) + F A * B becomes F A (*) B + Proxy * becomes Proxy (*) + a * -> * becomes a (*) -> * +-} + +{- +************************************************************************ +* * + Tuples +* * +************************************************************************ +-} + +data TupleSort + = BoxedTuple + | UnboxedTuple + | ConstraintTuple + deriving( Eq, Data ) + +instance Outputable TupleSort where + ppr ts = text $ + case ts of + BoxedTuple -> "BoxedTuple" + UnboxedTuple -> "UnboxedTuple" + ConstraintTuple -> "ConstraintTuple" + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity ConstraintTuple = Boxed + +boxityTupleSort :: Boxity -> TupleSort +boxityTupleSort Boxed = BoxedTuple +boxityTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") +tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) + = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + (parens p) + +{- +************************************************************************ +* * + Sums +* * +************************************************************************ +-} + +sumParens :: SDoc -> SDoc +sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") + +-- | Pretty print an alternative in an unboxed sum e.g. "| a | |". +pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use + -> a -- ^ The things to be pretty printed + -> ConTag -- ^ Alternative (one-based) + -> Arity -- ^ Arity + -> SDoc -- ^ 'SDoc' where the alternative havs been pretty + -- printed and finally packed into a paragraph. +pprAlternative pp x alt arity = + fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) + +{- +************************************************************************ +* * +\subsection[Generic]{Generic flag} +* * +************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. +-} + +-- | Embedding Projection pair +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T + +{- +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +************************************************************************ +* * +\subsection{Occurrence information} +* * +************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty +near the base of the module hierarchy. So it seemed simpler to put the defn of +OccInfo here, safely at the bottom +-} + +-- | identifier Occurrence Information +data OccInfo + = ManyOccs { occ_tail :: !TailCallInfo } + -- ^ There are many occurrences, or unknown occurrences + + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc { occ_in_lam :: !InsideLam + , occ_one_br :: !OneBranch + , occ_int_cxt :: !InterestingCxt + , occ_tail :: !TailCallInfo } + -- ^ Occurs exactly once (per branch), not inside a rule + + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker { occ_rules_only :: !RulesOnly + , occ_tail :: !TailCallInfo } + -- Note [LoopBreaker OccInfo] + deriving (Eq) + +type RulesOnly = Bool + +{- +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all + +See OccurAnal Note [Weak loop breakers] +-} + +noOccInfo :: OccInfo +noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } + +isManyOccs :: OccInfo -> Bool +isManyOccs ManyOccs{} = True +isManyOccs _ = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +-- | Interesting Context +data InterestingCxt + = IsInteresting + -- ^ Function: is applied + -- Data value: scrutinised by a case with at least one non-DEFAULT branch + | NotInteresting + deriving (Eq) + +-- | If there is any 'interesting' identifier occurrence, then the +-- aggregated occurrence info of that identifier is considered interesting. +instance Semi.Semigroup InterestingCxt where + NotInteresting <> x = x + IsInteresting <> _ = IsInteresting + +instance Monoid InterestingCxt where + mempty = NotInteresting + mappend = (Semi.<>) + +----------------- +-- | Inside Lambda +data InsideLam + = IsInsideLam + -- ^ Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. + | NotInsideLam + deriving (Eq) + +-- | If any occurrence of an identifier is inside a lambda, then the +-- occurrence info of that identifier marks it as occurring inside a lambda +instance Semi.Semigroup InsideLam where + NotInsideLam <> x = x + IsInsideLam <> _ = IsInsideLam + +instance Monoid InsideLam where + mempty = NotInsideLam + mappend = (Semi.<>) + +----------------- +data OneBranch + = InOneBranch + -- ^ One syntactic occurrence: Occurs in only one case branch + -- so no code-duplication issue to worry about + | MultipleBranches + deriving (Eq) + +----------------- +data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] + | NoTailCallInfo + deriving (Eq) + +tailCallInfo :: OccInfo -> TailCallInfo +tailCallInfo IAmDead = NoTailCallInfo +tailCallInfo other = occ_tail other + +zapOccTailCallInfo :: OccInfo -> OccInfo +zapOccTailCallInfo IAmDead = IAmDead +zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } + +isAlwaysTailCalled :: OccInfo -> Bool +isAlwaysTailCalled occ + = case tailCallInfo occ of AlwaysTailCalled{} -> True + NoTailCallInfo -> False + +instance Outputable TailCallInfo where + ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] + ppr _ = empty + +----------------- +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo +weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker{}) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True + -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc _ = False + +isOneOcc :: OccInfo -> Bool +isOneOcc (OneOcc {}) = True +isOneOcc _ = False + +zapFragileOcc :: OccInfo -> OccInfo +-- Keep only the most robust data: deadness, loop-breaker-hood +zapFragileOcc (OneOcc {}) = noOccInfo +zapFragileOcc occ = zapOccTailCallInfo occ + +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr (ManyOccs tails) = pprShortTailCallInfo tails + ppr IAmDead = text "Dead" + ppr (IAmALoopBreaker rule_only tails) + = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails + where + pp_ro | rule_only = char '!' + | otherwise = empty + ppr (OneOcc inside_lam one_branch int_cxt tail_info) + = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail + where + pp_lam IsInsideLam = char 'L' + pp_lam NotInsideLam = empty + pp_br MultipleBranches = char '*' + pp_br InOneBranch = empty + pp_args IsInteresting = char '!' + pp_args NotInteresting = empty + pp_tail = pprShortTailCallInfo tail_info + +pprShortTailCallInfo :: TailCallInfo -> SDoc +pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) +pprShortTailCallInfo NoTailCallInfo = empty + +{- +Note [TailCallInfo] +~~~~~~~~~~~~~~~~~~~ +The occurrence analyser determines what can be made into a join point, but it +doesn't change the binder into a JoinId because then it would be inconsistent +with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to +change the IdDetails. + +The AlwaysTailCalled marker actually means slightly more than simply that the +function is always tail-called. See Note [Invariants on join points]. + +This info is quite fragile and should not be relied upon unless the occurrence +analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of +the join-point-hood of a binder; a join id itself will not be marked +AlwaysTailCalled. + +Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that +being tail-called would mean that the variable could only appear once per branch +(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join +point can also be invoked from other join points, not just from case branches: + + let j1 x = ... + j2 y = ... j1 z {- tail call -} ... + in case w of + A -> j1 v + B -> j2 u + C -> j2 q + +Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get +ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. + +************************************************************************ +* * + Default method specification +* * +************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMethInfo before begin put in a +Class object. +-} + +-- | Default Method Specification +data DefMethSpec ty + = VanillaDM -- Default method given with polymorphic code + | GenericDM ty -- Default method given with code of this type + +instance Outputable (DefMethSpec ty) where + ppr VanillaDM = text "{- Has default method -}" + ppr (GenericDM {}) = text "{- Has generic default method -}" + +{- +************************************************************************ +* * +\subsection{Success flag} +* * +************************************************************************ +-} + +data SuccessFlag = Succeeded | Failed + +instance Outputable SuccessFlag where + ppr Succeeded = text "Succeeded" + ppr Failed = text "Failed" + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True + +{- +************************************************************************ +* * +\subsection{Source Text} +* * +************************************************************************ +Keeping Source Text for source to source conversions + +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [Literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n' == '\x20` + HsCharPrim '\x41`# == `A` + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# == " "# + HsInt 001 == 1 + HsIntPrim 002# == 2# + HsWordPrim 003## == 3## + HsInt64Prim 004## == 4## + HsWord64Prim 005## == 5## + HsInteger 006 == 6 + +For OverLitVal + + HsIntegral 003 == 0x003 + HsIsString "\x41nd" == "And" +-} + + -- Note [Literal source text],[Pragma source text] +data SourceText = SourceText String + | NoSourceText -- ^ For when code is generated, e.g. TH, + -- deriving. The pretty printer will then make + -- its own representation of the item. + deriving (Data, Show, Eq ) + +instance Outputable SourceText where + ppr (SourceText s) = text "SourceText" <+> text s + ppr NoSourceText = text "NoSourceText" + +-- | Special combinator for showing string literals. +pprWithSourceText :: SourceText -> SDoc -> SDoc +pprWithSourceText NoSourceText d = d +pprWithSourceText (SourceText src) _ = text src + +{- +************************************************************************ +* * +\subsection{Activation} +* * +************************************************************************ + +When a rule or inlining is active +-} + +-- | Phase Number +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = Phase PhaseNum + | InitialPhase -- The first phase -- number = infinity! + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = text "InitialPhase" + +activeAfterInitial :: Activation +-- Active in the first phase after the initial phase +-- Currently we have just phases [2,1,0] +activeAfterInitial = ActiveAfter NoSourceText 2 + +activeDuringFinal :: Activation +-- Active in the final simplification phase (which is repeated) +activeDuringFinal = ActiveAfter NoSourceText 0 + +-- See note [Pragma source text] +data Activation = NeverActive + | AlwaysActive + | ActiveBefore SourceText PhaseNum + -- Active only *strictly before* this phase + | ActiveAfter SourceText PhaseNum + -- Active in this phase and later + deriving( Eq, Data ) + -- Eq used in comparing rules in GHC.Hs.Decls + +-- | Rule Match Information +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq, Data, Show ) + -- Show needed for Lexer.x + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_src :: SourceText -- Note [Pragma source text] + , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] + + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the Unfolding, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + -- See Note [inl_inline and inl_act] + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data ) + +-- | Inline Specification +data InlineSpec -- What the user's INLINE pragma looked like + = Inline -- User wrote INLINE + | Inlinable -- User wrote INLINABLE + | NoInline -- User wrote NOINLINE + | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE + -- e.g. in `defaultInlinePragma` or when created by CSE + deriving( Eq, Data, Show ) + -- Show needed for Lexer.x + +{- Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = NoUserInline + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. + +If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair + +Note [inl_inline and inl_act] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* inl_inline says what the user wrote: did she say INLINE, NOINLINE, + INLINABLE, or nothing at all + +* inl_act says in what phases the unfolding is active or inactive + E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 + If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 + If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 + So note that inl_act does not say what pragma you wrote: it just + expresses its consequences + +* inl_act just says when the unfolding is active; it doesn't say what + to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, + but in addition f will get a "stable unfolding" with UnfoldingGuidance + that tells the inliner to be pretty eager about it. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in GHC.Core.Rules. +-} + +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +noUserInlineSpec :: InlineSpec -> Bool +noUserInlineSpec NoUserInline = True +noUserInlineSpec _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = NoUserInline + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } + +instance Outputable Activation where + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore _ n) = brackets (char '~' <> int n) + ppr (ActiveAfter _ n) = brackets (int n) + +instance Outputable RuleMatchInfo where + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + +instance Outputable InlineSpec where + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" + ppr NoUserInline = text "NOUSERINLINE" -- what is better? + +instance Outputable InlinePragma where + ppr = pprInline + +pprInline :: InlinePragma -> SDoc +pprInline = pprInline' True + +pprInlineDebug :: InlinePragma -> SDoc +pprInlineDebug = pprInline' False + +pprInline' :: Bool -- True <=> do not display the inl_inline field + -> InlinePragma + -> SDoc +pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_inl x = if emptyInline then empty else ppr x + + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = ppr act + + pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase AlwaysActive = True +isActive InitialPhase (ActiveBefore {}) = True +isActive InitialPhase _ = False +isActive (Phase p) act = isActiveIn p act + +isActiveIn :: PhaseNum -> Activation -> Bool +isActiveIn _ NeverActive = False +isActiveIn _ AlwaysActive = True +isActiveIn p (ActiveAfter _ n) = p <= n +isActiveIn p (ActiveBefore _ n) = p > n + +competesWith :: Activation -> Activation -> Bool +-- See Note [Activation competition] +competesWith NeverActive _ = False +competesWith _ NeverActive = False +competesWith AlwaysActive _ = True + +competesWith (ActiveBefore {}) AlwaysActive = True +competesWith (ActiveBefore {}) (ActiveBefore {}) = True +competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b + +competesWith (ActiveAfter {}) AlwaysActive = False +competesWith (ActiveAfter {}) (ActiveBefore {}) = False +competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b + +{- Note [Competing activations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes a RULE and an inlining may compete, or two RULES. +See Note [Rules and inlining/other rules] in GHC.HsToCore. + +We say that act1 "competes with" act2 iff + act1 is active in the phase when act2 *becomes* active +NB: remember that phases count *down*: 2, 1, 0! + +It's too conservative to ensure that the two are never simultaneously +active. For example, a rule might be always active, and an inlining +might switch on in phase 2. We could switch off the rule, but it does +no harm. +-} + +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False + +-- | Integral Literal +-- +-- Used (instead of Integer) to represent negative zegative zero which is +-- required for NegativeLiterals extension to correctly parse `-0::Double` +-- as negative zero. See also #13211. +data IntegralLit + = IL { il_text :: SourceText + , il_neg :: Bool -- See Note [Negative zero] + , il_value :: Integer + } + deriving (Data, Show) + +mkIntegralLit :: Integral a => a -> IntegralLit +mkIntegralLit i = IL { il_text = SourceText (show i_integer) + , il_neg = i < 0 + , il_value = i_integer } + where + i_integer :: Integer + i_integer = toInteger i + +negateIntegralLit :: IntegralLit -> IntegralLit +negateIntegralLit (IL text neg value) + = case text of + SourceText ('-':src) -> IL (SourceText src) False (negate value) + SourceText src -> IL (SourceText ('-':src)) True (negate value) + NoSourceText -> IL NoSourceText (not neg) (negate value) + +-- | Fractional Literal +-- +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: SourceText -- How the value was written in the source + , fl_neg :: Bool -- See Note [Negative zero] + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Show) + -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on + +mkFractionalLit :: Real a => a -> FractionalLit +mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) + -- Converting to a Double here may technically lose + -- precision (see #15502). We could alternatively + -- convert to a Rational for the most accuracy, but + -- it would cause Floats and Doubles to be displayed + -- strangely, so we opt not to do this. (In contrast + -- to mkIntegralLit, where we always convert to an + -- Integer for the highest accuracy.) + , fl_neg = r < 0 + , fl_value = toRational r } + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL text neg value) + = case text of + SourceText ('-':src) -> FL (SourceText src) False value + SourceText src -> FL (SourceText ('-':src)) True value + NoSourceText -> FL NoSourceText (not neg) (negate value) + +integralFractionalLit :: Bool -> Integer -> FractionalLit +integralFractionalLit neg i = FL { fl_text = SourceText (show i), + fl_neg = neg, + fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) + +instance Eq IntegralLit where + (==) = (==) `on` il_value + +instance Ord IntegralLit where + compare = compare `on` il_value + +instance Outputable IntegralLit where + ppr (IL (SourceText src) _ _) = text src + ppr (IL NoSourceText _ value) = text (show value) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) + +{- +************************************************************************ +* * + IntWithInf +* * +************************************************************************ + +Represents an integer or positive infinity + +-} + +-- | An integer or infinity +data IntWithInf = Int {-# UNPACK #-} !Int + | Infinity + deriving Eq + +-- | A representation of infinity +infinity :: IntWithInf +infinity = Infinity + +instance Ord IntWithInf where + compare Infinity Infinity = EQ + compare (Int _) Infinity = LT + compare Infinity (Int _) = GT + compare (Int a) (Int b) = a `compare` b + +instance Outputable IntWithInf where + ppr Infinity = char '∞' + ppr (Int n) = int n + +instance Num IntWithInf where + (+) = plusWithInf + (*) = mulWithInf + + abs Infinity = Infinity + abs (Int n) = Int (abs n) + + signum Infinity = Int 1 + signum (Int n) = Int (signum n) + + fromInteger = Int . fromInteger + + (-) = panic "subtracting IntWithInfs" + +intGtLimit :: Int -> IntWithInf -> Bool +intGtLimit _ Infinity = False +intGtLimit n (Int m) = n > m + +-- | Add two 'IntWithInf's +plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf Infinity _ = Infinity +plusWithInf _ Infinity = Infinity +plusWithInf (Int a) (Int b) = Int (a + b) + +-- | Multiply two 'IntWithInf's +mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf _ Infinity = Infinity +mulWithInf (Int a) (Int b) = Int (a * b) + +-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity +treatZeroAsInf :: Int -> IntWithInf +treatZeroAsInf 0 = Infinity +treatZeroAsInf n = Int n + +-- | Inject any integer into an 'IntWithInf' +mkIntWithInf :: Int -> IntWithInf +mkIntWithInf = Int + +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 diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/CostCentre.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module GHC.Types.CostCentre ( + CostCentre(..), CcName, CCFlavour(..), + -- All abstract except to friend: ParseIface.y + + CostCentreStack, + CollectedCCs, emptyCollectedCCs, collectCC, + currentCCS, dontCareCCS, + isCurrentCCS, + maybeSingletonCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, + + pprCostCentreCore, + costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, + + cmpCostCentre -- used for removing dups in a list + ) where + +import GhcPrelude + +import Binary +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Module +import GHC.Types.Unique +import Outputable +import GHC.Types.SrcLoc +import FastString +import Util +import GHC.Types.CostCentre.State + +import Data.Data + +----------------------------------------------------------------------------- +-- Cost Centres + +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. + +data CostCentre + = NormalCC { + cc_flavour :: CCFlavour, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has an + -- associated flavour that indicates how it was + -- generated, and flavours that allow multiple instances + -- of the same name and module have a deterministic 0-based + -- index. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan + } + deriving Data + +type CcName = FastString + +-- | The flavour of a cost centre. +-- +-- Index fields represent 0-based indices giving source-code ordering of +-- centres with the same module, name, and flavour. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk + | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression + | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration + | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage + deriving (Eq, Ord, Data) + +-- | Extract the index from a flavour +flavourIndex :: CCFlavour -> Int +flavourIndex CafCC = 0 +flavourIndex (ExprCC x) = unCostCentreIndex x +flavourIndex (DeclCC x) = unCostCentreIndex x +flavourIndex (HpcCC x) = unCostCentreIndex x + +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + +instance Ord CostCentre where + compare = cmpCostCentre + +cmpCostCentre :: CostCentre -> CostCentre -> Ordering + +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 + +cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} + NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} + -- first key is module name, then centre name, then flavour + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) + +cmpCostCentre other_1 other_2 + = let + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 + in + if tag1 < tag2 then LT else GT + where + tag_CC :: CostCentre -> Int + tag_CC (NormalCC {}) = 0 + tag_CC (AllCafsCC {}) = 1 + + +----------------------------------------------------------------------------- +-- Predicates on CostCentre + +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_flavour = CafCC}) = True +isCafCC _ = False + +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True + +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC cc | isCafCC cc = False + | otherwise = True + +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m + + +----------------------------------------------------------------------------- +-- Building cost centres + +mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre +mkUserCC cc_name mod loc flavour + = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, + cc_flavour = flavour + } + +mkAutoCC :: Id -> Module -> CostCentre +mkAutoCC id mod + = NormalCC { cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), + cc_flavour = CafCC + } + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = occNameFS (getOccName id) + `appendFS` + mkFastString ('_' : show (getUnique name)) +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } + +----------------------------------------------------------------------------- +-- Cost Centre Stacks + +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). + +data CostCentreStack + = CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. + + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. + + | SingletonCCS CostCentre + + deriving (Eq, Ord) -- needed for Ord on CLabel + + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) + +emptyCollectedCCs :: CollectedCCs +emptyCollectedCCs = ([], []) + +collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs +collectCC cc ccs (c, cs) = (cc : c, ccs : cs) + +currentCCS, dontCareCCS :: CostCentreStack + +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS + +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks + +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False + +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False + +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing + +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc + + +----------------------------------------------------------------------------- +-- Printing Cost Centre Stacks. + +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. + +instance Outputable CostCentreStack where + ppr CurrentCCS = text "CCCS" + ppr DontCareCCS = text "CCS_DONT_CARE" + ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + + +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. + +instance Outputable CostCentre where + ppr cc = getPprStyle $ \ sty -> + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in Core +pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, + cc_mod = m, cc_loc = loc}) + = text "__scc" <+> braces (hsep [ + ppr m <> char '.' <> ftext n, + pprFlavourCore flavour, + whenPprDebug (ppr loc) + ]) + +-- ^ Print a flavour in Core +pprFlavourCore :: CCFlavour -> SDoc +pprFlavourCore CafCC = text "__C" +pprFlavourCore f = pprIdxCore $ flavourIndex f + +-- ^ Print a flavour's index in Core +pprIdxCore :: Int -> SDoc +pprIdxCore 0 = empty +pprIdxCore idx = whenPprDebug $ ppr idx + +-- Printing as a C label +ppCostCentreLbl :: CostCentre -> SDoc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) + = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + ppFlavourLblComponent f <> text "_cc" + +-- ^ Print the flavour component of a C label +ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent CafCC = text "CAF" +ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i +ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i +ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i + +-- ^ Print the flavour index component of a C label +ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent n = + case unCostCentreIndex n of + 0 -> empty + n -> ppr n + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName :: CostCentre -> String +costCentreUserName = unpackFS . costCentreUserNameFS + +costCentreUserNameFS :: CostCentre -> FastString +costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" +costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) + = case is_caf of + CafCC -> mkFastString "CAF:" `appendFS` name + _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc + +instance Binary CCFlavour where + put_ bh CafCC = do + putByte bh 0 + put_ bh (ExprCC i) = do + putByte bh 1 + put_ bh i + put_ bh (DeclCC i) = do + putByte bh 2 + put_ bh i + put_ bh (HpcCC i) = do + putByte bh 3 + put_ bh i + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + 1 -> ExprCC <$> get bh + 2 -> DeclCC <$> get bh + _ -> HpcCC <$> get bh + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + return (NormalCC aa ab ac noSrcSpan) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. diff --git a/compiler/GHC/Types/CostCentre/State.hs b/compiler/GHC/Types/CostCentre/State.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/CostCentre/State.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Types.CostCentre.State + ( CostCentreState + , newCostCentreState + , CostCentreIndex + , unCostCentreIndex + , getCCIndex + ) +where + +import GhcPrelude +import FastString +import FastStringEnv + +import Data.Data +import Binary + +-- | Per-module state for tracking cost centre indices. +-- +-- See documentation of 'CostCentre.cc_flavour' for more details. +newtype CostCentreState = CostCentreState (FastStringEnv Int) + +-- | Initialize cost centre state. +newCostCentreState :: CostCentreState +newCostCentreState = CostCentreState emptyFsEnv + +-- | An index into a given cost centre module,name,flavour set +newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } + deriving (Eq, Ord, Data, Binary) + +-- | Get a new index for a given cost centre name. +getCCIndex :: FastString + -> CostCentreState + -> (CostCentreIndex, CostCentreState) +getCCIndex nm (CostCentreState m) = + (CostCentreIndex idx, CostCentreState m') + where + m_idx = lookupFsEnv m nm + idx = maybe 0 id m_idx + m' = extendFsEnv m nm (idx + 1) diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Cpr.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +-- | Types for the Constructed Product Result lattice. "GHC.Core.Op.CprAnal" and "GHC.Core.Op.WorkWrap.Lib" +-- are its primary customers via 'idCprInfo'. +module GHC.Types.Cpr ( + CprResult, topCpr, botCpr, conCpr, asConCpr, + CprType (..), topCprType, botCprType, conCprType, + lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy, + CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig + ) where + +import GhcPrelude + +import GHC.Types.Basic +import Outputable +import Binary + +-- +-- * CprResult +-- + +-- | The constructed product result lattice. +-- +-- @ +-- NoCPR +-- | +-- ConCPR ConTag +-- | +-- BotCPR +-- @ +data CprResult = NoCPR -- ^ Top of the lattice + | ConCPR !ConTag -- ^ Returns a constructor from a data type + | BotCPR -- ^ Bottom of the lattice + deriving( Eq, Show ) + +lubCpr :: CprResult -> CprResult -> CprResult +lubCpr (ConCPR t1) (ConCPR t2) + | t1 == t2 = ConCPR t1 +lubCpr BotCPR cpr = cpr +lubCpr cpr BotCPR = cpr +lubCpr _ _ = NoCPR + +topCpr :: CprResult +topCpr = NoCPR + +botCpr :: CprResult +botCpr = BotCPR + +conCpr :: ConTag -> CprResult +conCpr = ConCPR + +trimCpr :: CprResult -> CprResult +trimCpr ConCPR{} = NoCPR +trimCpr cpr = cpr + +asConCpr :: CprResult -> Maybe ConTag +asConCpr (ConCPR t) = Just t +asConCpr NoCPR = Nothing +asConCpr BotCPR = Nothing + +-- +-- * CprType +-- + +-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. +data CprType + = CprType + { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression + -- eats before returning the 'ct_cpr' + , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to + -- 'ct_arty' arguments + } + +instance Eq CprType where + a == b = ct_cpr a == ct_cpr b + && (ct_arty a == ct_arty b || ct_cpr a == topCpr) + +topCprType :: CprType +topCprType = CprType 0 topCpr + +botCprType :: CprType +botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments + +conCprType :: ConTag -> CprType +conCprType con_tag = CprType 0 (conCpr con_tag) + +lubCprType :: CprType -> CprType -> CprType +lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) + -- The arity of bottom CPR types can be extended arbitrarily. + | cpr1 == botCpr && n1 <= n2 = ty2 + | cpr2 == botCpr && n2 <= n1 = ty1 + -- There might be non-bottom CPR types with mismatching arities. + -- Consider test DmdAnalGADTs. We want to return top in these cases. + | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) + | otherwise = topCprType + +applyCprTy :: CprType -> CprType +applyCprTy (CprType n res) + | n > 0 = CprType (n-1) res + | res == botCpr = botCprType + | otherwise = topCprType + +abstractCprTy :: CprType -> CprType +abstractCprTy (CprType n res) + | res == topCpr = topCprType + | otherwise = CprType (n+1) res + +ensureCprTyArity :: Arity -> CprType -> CprType +ensureCprTyArity n ty@(CprType m _) + | n == m = ty + | otherwise = topCprType + +trimCprTy :: CprType -> CprType +trimCprTy (CprType arty res) = CprType arty (trimCpr res) + +-- | The arity of the wrapped 'CprType' is the arity at which it is safe +-- to unleash. See Note [Understanding DmdType and StrictSig] in GHC.Types.Demand +newtype CprSig = CprSig { getCprSig :: CprType } + deriving (Eq, Binary) + +-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' +-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in +-- Demand +mkCprSigForArity :: Arity -> CprType -> CprSig +mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) + +topCprSig :: CprSig +topCprSig = CprSig topCprType + +mkCprSig :: Arity -> CprResult -> CprSig +mkCprSig arty cpr = CprSig (CprType arty cpr) + +seqCprSig :: CprSig -> () +seqCprSig sig = sig `seq` () + +instance Outputable CprResult where + ppr NoCPR = empty + ppr (ConCPR n) = char 'm' <> int n + ppr BotCPR = char 'b' + +instance Outputable CprType where + ppr (CprType arty res) = ppr arty <> ppr res + +-- | Only print the CPR result +instance Outputable CprSig where + ppr (CprSig ty) = ppr (ct_cpr ty) + +instance Binary CprResult where + put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } + put_ bh NoCPR = putByte bh 1 + put_ bh BotCPR = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (ConCPR n) } + 1 -> return NoCPR + _ -> return BotCPR + +instance Binary CprType where + put_ bh (CprType arty cpr) = do + put_ bh arty + put_ bh cpr + get bh = CprType <$> get bh <*> get bh diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Demand.hs @@ -0,0 +1,1974 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Demand]{@Demand@: A decoupled implementation of a demand domain} +-} + +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Demand ( + StrDmd, UseDmd(..), Count, + + Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, + mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, + toCleanDmd, + absDmd, topDmd, botDmd, seqDmd, + lubDmd, bothDmd, + lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, + isTopDmd, isAbsDmd, isSeqDmd, + peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, + addCaseBndrDmd, + + DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, + nopDmdType, botDmdType, mkDmdType, + addDemand, ensureArgs, + BothDmdArg, mkBothDmdArg, toBothDmdArg, + + DmdEnv, emptyDmdEnv, + peelFV, findIdDemand, + + Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv, + appIsBottom, isBottomingSig, pprIfaceStrictSig, + StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, + nopSig, botSig, cprProdSig, + isTopSig, hasDemandEnvSig, + splitStrictSig, strictSigDmdEnv, + increaseStrictSigArity, etaExpandStrictSig, + + seqDemand, seqDemandList, seqDmdType, seqStrictSig, + + evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, + splitDmdTy, splitFVs, + deferAfterIO, + postProcessUnsat, postProcessDmdType, + + splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, + mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, + dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, + TypeShape(..), peelTsFuns, trimToType, + + useCount, isUsedOnce, reuseEnv, + zapUsageDemand, zapUsageEnvSig, + zapUsedOnceDemand, zapUsedOnceSig, + strictifyDictDmd, strictifyDmd + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Outputable +import GHC.Types.Var ( Var ) +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import Util +import GHC.Types.Basic +import Binary +import Maybes ( orElse ) + +import GHC.Core.Type ( Type ) +import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) +import GHC.Core.DataCon ( splitDataProductType_maybe ) + +{- +************************************************************************ +* * + Joint domain for Strictness and Absence +* * +************************************************************************ +-} + +data JointDmd s u = JD { sd :: s, ud :: u } + deriving ( Eq, Show ) + +getStrDmd :: JointDmd s u -> s +getStrDmd = sd + +getUseDmd :: JointDmd s u -> u +getUseDmd = ud + +-- Pretty-printing +instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where + ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) + +-- Well-formedness preserving constructors for the joint domain +mkJointDmd :: s -> u -> JointDmd s u +mkJointDmd s u = JD { sd = s, ud = u } + +mkJointDmds :: [s] -> [u] -> [JointDmd s u] +mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as + + +{- +************************************************************************ +* * + Strictness domain +* * +************************************************************************ + + Lazy + | + HeadStr + / \ + SCall SProd + \ / + HyperStr + +Note [Exceptions and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to smart about catching exceptions, but we aren't anymore. +See #14998 for the way it's resolved at the moment. + +Here's a historic breakdown: + +Apparently, exception handling prim-ops didn't use to have any special +strictness signatures, thus defaulting to topSig, which assumes they use their +arguments lazily. Joachim was the first to realise that we could provide richer +information. Thus, in 0558911f91c (Dec 13), he added signatures to +primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call +their argument, which is useful information for usage analysis. Still with a +'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. + +In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a +'strictApply1Dmd' leads to substantial performance gains. That was at the cost +of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in +28638dfe79e (Dec 15). + +Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, +Ben opened #11222. Simon made the demand analyser "understand catch" in +9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call +its argument strictly, but also swallow any thrown exceptions in +'postProcessDivergence'. This was realized by extending the 'Str' constructor of +'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and +adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element +between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, +so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). + +This left the other variants like 'catchRetry#' having 'catchArgDmd', which is +where #14998 picked up. Item 1 was concerned with measuring the impact of also +making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that +there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 +(Apr 18). There was a lot of dead code resulting from that change, that we +removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and +removed any code that was dealing with the peculiarities. + +Where did the speed-ups vanish to? In #14998, item 3 established that +turning 'catch#' strict in its first argument didn't bring back any of the +alleged performance benefits. Item 2 of that ticket finally found out that it +was entirely due to 'catchException's new (since #11555) definition, which +was simply + + catchException !io handler = catch io handler + +While 'catchException' is arguably the saner semantics for 'catch', it is an +internal helper function in "GHC.IO". Its use in +"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: +Remove the bang and you find the regressions we originally wanted to avoid with +'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". + +So history keeps telling us that the only possibly correct strictness annotation +for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really +is not strict in its argument: Just try this in GHCi + + :set -XScopedTypeVariables + import Control.Exception + catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") + +Any analysis that assumes otherwise will be broken in some way or another +(beyond `-fno-pendantic-bottoms`). +-} + +-- | Vanilla strictness domain +data StrDmd + = HyperStr -- ^ Hyper-strict (bottom of the lattice). + -- See Note [HyperStr and Use demands] + + | SCall StrDmd -- ^ Call demand + -- Used only for values of function type + + | SProd [ArgStr] -- ^ Product + -- Used only for values of product type + -- Invariant: not all components are HyperStr (use HyperStr) + -- not all components are Lazy (use HeadStr) + + | HeadStr -- ^ Head-Strict + -- A polymorphic demand: used for values of all types, + -- including a type variable + + deriving ( Eq, Show ) + +-- | Strictness of a function argument. +type ArgStr = Str StrDmd + +-- | Strictness demand. +data Str s = Lazy -- ^ Lazy (top of the lattice) + | Str s -- ^ Strict + deriving ( Eq, Show ) + +-- Well-formedness preserving constructors for the Strictness domain +strBot, strTop :: ArgStr +strBot = Str HyperStr +strTop = Lazy + +mkSCall :: StrDmd -> StrDmd +mkSCall HyperStr = HyperStr +mkSCall s = SCall s + +mkSProd :: [ArgStr] -> StrDmd +mkSProd sx + | any isHyperStr sx = HyperStr + | all isLazy sx = HeadStr + | otherwise = SProd sx + +isLazy :: ArgStr -> Bool +isLazy Lazy = True +isLazy (Str {}) = False + +isHyperStr :: ArgStr -> Bool +isHyperStr (Str HyperStr) = True +isHyperStr _ = False + +-- Pretty-printing +instance Outputable StrDmd where + ppr HyperStr = char 'B' + ppr (SCall s) = char 'C' <> parens (ppr s) + ppr HeadStr = char 'S' + ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) + +instance Outputable ArgStr where + ppr (Str s) = ppr s + ppr Lazy = char 'L' + +lubArgStr :: ArgStr -> ArgStr -> ArgStr +lubArgStr Lazy _ = Lazy +lubArgStr _ Lazy = Lazy +lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) + +lubStr :: StrDmd -> StrDmd -> StrDmd +lubStr HyperStr s = s +lubStr (SCall s1) HyperStr = SCall s1 +lubStr (SCall _) HeadStr = HeadStr +lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) +lubStr (SCall _) (SProd _) = HeadStr +lubStr (SProd sx) HyperStr = SProd sx +lubStr (SProd _) HeadStr = HeadStr +lubStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) + | otherwise = HeadStr +lubStr (SProd _) (SCall _) = HeadStr +lubStr HeadStr _ = HeadStr + +bothArgStr :: ArgStr -> ArgStr -> ArgStr +bothArgStr Lazy s = s +bothArgStr s Lazy = s +bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) + +bothStr :: StrDmd -> StrDmd -> StrDmd +bothStr HyperStr _ = HyperStr +bothStr HeadStr s = s +bothStr (SCall _) HyperStr = HyperStr +bothStr (SCall s1) HeadStr = SCall s1 +bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) +bothStr (SCall _) (SProd _) = HyperStr -- Weird + +bothStr (SProd _) HyperStr = HyperStr +bothStr (SProd s1) HeadStr = SProd s1 +bothStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) + | otherwise = HyperStr -- Weird +bothStr (SProd _) (SCall _) = HyperStr + +-- utility functions to deal with memory leaks +seqStrDmd :: StrDmd -> () +seqStrDmd (SProd ds) = seqStrDmdList ds +seqStrDmd (SCall s) = seqStrDmd s +seqStrDmd _ = () + +seqStrDmdList :: [ArgStr] -> () +seqStrDmdList [] = () +seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds + +seqArgStr :: ArgStr -> () +seqArgStr Lazy = () +seqArgStr (Str s) = seqStrDmd s + +-- Splitting polymorphic demands +splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] +splitArgStrProdDmd n Lazy = Just (replicate n Lazy) +splitArgStrProdDmd n (Str s) = splitStrProdDmd n s + +splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] +splitStrProdDmd n HyperStr = Just (replicate n strBot) +splitStrProdDmd n HeadStr = Just (replicate n strTop) +splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), + text "splitStrProdDmd" $$ ppr n $$ ppr ds ) + Just ds +splitStrProdDmd _ (SCall {}) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +{- +************************************************************************ +* * + Absence domain +* * +************************************************************************ + + Used + / \ + UCall UProd + \ / + UHead + | + Count x - + | + Abs +-} + +-- | Domain for genuine usage +data UseDmd + = UCall Count UseDmd -- ^ Call demand for absence. + -- Used only for values of function type + + | UProd [ArgUse] -- ^ Product. + -- Used only for values of product type + -- See Note [Don't optimise UProd(Used) to Used] + -- + -- Invariant: Not all components are Abs + -- (in that case, use UHead) + + | UHead -- ^ May be used but its sub-components are + -- definitely *not* used. For product types, UHead + -- is equivalent to U(AAA); see mkUProd. + -- + -- UHead is needed only to express the demand + -- of 'seq' and 'case' which are polymorphic; + -- i.e. the scrutinised value is of type 'a' + -- rather than a product type. That's why we + -- can't use UProd [A,A,A] + -- + -- Since (UCall _ Abs) is ill-typed, UHead doesn't + -- make sense for lambdas + + | Used -- ^ May be used and its sub-components may be used. + -- (top of the lattice) + deriving ( Eq, Show ) + +-- Extended usage demand for absence and counting +type ArgUse = Use UseDmd + +data Use u + = Abs -- Definitely unused + -- Bottom of the lattice + + | Use Count u -- May be used with some cardinality + deriving ( Eq, Show ) + +-- | Abstract counting of usages +data Count = One | Many + deriving ( Eq, Show ) + +-- Pretty-printing +instance Outputable ArgUse where + ppr Abs = char 'A' + ppr (Use Many a) = ppr a + ppr (Use One a) = char '1' <> char '*' <> ppr a + +instance Outputable UseDmd where + ppr Used = char 'U' + ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) + ppr UHead = char 'H' + ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) + +instance Outputable Count where + ppr One = char '1' + ppr Many = text "" + +useBot, useTop :: ArgUse +useBot = Abs +useTop = Use Many Used + +mkUCall :: Count -> UseDmd -> UseDmd +--mkUCall c Used = Used c +mkUCall c a = UCall c a + +mkUProd :: [ArgUse] -> UseDmd +mkUProd ux + | all (== Abs) ux = UHead + | otherwise = UProd ux + +lubCount :: Count -> Count -> Count +lubCount _ Many = Many +lubCount Many _ = Many +lubCount x _ = x + +lubArgUse :: ArgUse -> ArgUse -> ArgUse +lubArgUse Abs x = x +lubArgUse x Abs = x +lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) + +lubUse :: UseDmd -> UseDmd -> UseDmd +lubUse UHead u = u +lubUse (UCall c u) UHead = UCall c u +lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) +lubUse (UCall _ _) _ = Used +lubUse (UProd ux) UHead = UProd ux +lubUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 + | otherwise = Used +lubUse (UProd {}) (UCall {}) = Used +-- lubUse (UProd {}) Used = Used +lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) +lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) +lubUse Used _ = Used -- Note [Used should win] + +-- `both` is different from `lub` in its treatment of counting; if +-- `both` is computed for two used, the result always has +-- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). +-- Also, x `bothUse` x /= x (for anything but Abs). + +bothArgUse :: ArgUse -> ArgUse -> ArgUse +bothArgUse Abs x = x +bothArgUse x Abs = x +bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) + + +bothUse :: UseDmd -> UseDmd -> UseDmd +bothUse UHead u = u +bothUse (UCall c u) UHead = UCall c u + +-- Exciting special treatment of inner demand for call demands: +-- use `lubUse` instead of `bothUse`! +bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) + +bothUse (UCall {}) _ = Used +bothUse (UProd ux) UHead = UProd ux +bothUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 + | otherwise = Used +bothUse (UProd {}) (UCall {}) = Used +-- bothUse (UProd {}) Used = Used -- Note [Used should win] +bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) +bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) +bothUse Used _ = Used -- Note [Used should win] + +peelUseCall :: UseDmd -> Maybe (Count, UseDmd) +peelUseCall (UCall c u) = Just (c,u) +peelUseCall _ = Nothing + +addCaseBndrDmd :: Demand -- On the case binder + -> [Demand] -- On the components of the constructor + -> [Demand] -- Final demands for the components of the constructor +-- See Note [Demand on case-alternative binders] +addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds + = case mu of + Abs -> alt_dmds + Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) + where + Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call + Just us = splitUseProdDmd arity u -- Ditto + where + arity = length alt_dmds + +{- Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis: + f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=] + { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +It's true that ds_dnz is *itself* absent, but the use of wild_X7 means +that it is very much alive and demanded. See #10148 for how the +consequences play out. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Don't optimise UProd(Used) to Used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two UseDmds: + UProd [Used, Used] and Used +are semantically equivalent, but we do not turn the former into +the latter, for a regrettable-subtle reason. Suppose we did. +then + f (x,y) = (y,x) +would get + StrDmd = Str = SProd [Lazy, Lazy] + UseDmd = Used = UProd [Used, Used] +But with the joint demand of doesn't convey any clue +that there is a product involved, and so the worthSplittingFun +will not fire. (We'd need to use the type as well to make it fire.) +Moreover, consider + g h p@(_,_) = h p +This too would get , but this time there really isn't any +point in w/w since the components of the pair are not used at all. + +So the solution is: don't aggressively collapse UProd [Used,Used] to +Used; instead leave it as-is. In effect we are using the UseDmd to do a +little bit of boxity analysis. Not very nice. + +Note [Used should win] +~~~~~~~~~~~~~~~~~~~~~~ +Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. +Why? Because Used carries the implication the whole thing is used, +box and all, so we don't want to w/w it. If we use it both boxed and +unboxed, then we are definitely using the box, and so we are quite +likely to pay a reboxing cost. So we make Used win here. + +Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer + +Baseline: (A) Not making Used win (UProd wins) +Compare with: (B) making Used win for lub and both + + Min -0.3% -5.6% -10.7% -11.0% -33.3% + Max +0.3% +45.6% +11.5% +11.5% +6.9% + Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% + +Baseline: (B) Making Used win for both lub and both +Compare with: (C) making Used win for both, but UProd win for lub + + Min -0.1% -0.3% -7.9% -8.0% -6.5% + Max +0.1% +1.0% +21.0% +21.0% +0.5% + Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% +-} + +-- If a demand is used multiple times (i.e. reused), than any use-once +-- mentioned there, that is not protected by a UCall, can happen many times. +markReusedDmd :: ArgUse -> ArgUse +markReusedDmd Abs = Abs +markReusedDmd (Use _ a) = Use Many (markReused a) + +markReused :: UseDmd -> UseDmd +markReused (UCall _ u) = UCall Many u -- No need to recurse here +markReused (UProd ux) = UProd (map markReusedDmd ux) +markReused u = u + +isUsedMU :: ArgUse -> Bool +-- True <=> markReusedDmd d = d +isUsedMU Abs = True +isUsedMU (Use One _) = False +isUsedMU (Use Many u) = isUsedU u + +isUsedU :: UseDmd -> Bool +-- True <=> markReused d = d +isUsedU Used = True +isUsedU UHead = True +isUsedU (UProd us) = all isUsedMU us +isUsedU (UCall One _) = False +isUsedU (UCall Many _) = True -- No need to recurse + +-- Squashing usage demand demands +seqUseDmd :: UseDmd -> () +seqUseDmd (UProd ds) = seqArgUseList ds +seqUseDmd (UCall c d) = c `seq` seqUseDmd d +seqUseDmd _ = () + +seqArgUseList :: [ArgUse] -> () +seqArgUseList [] = () +seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds + +seqArgUse :: ArgUse -> () +seqArgUse (Use c u) = c `seq` seqUseDmd u +seqArgUse _ = () + +-- Splitting polymorphic Maybe-Used demands +splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] +splitUseProdDmd n Used = Just (replicate n useTop) +splitUseProdDmd n UHead = Just (replicate n Abs) +splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), + text "splitUseProdDmd" $$ ppr n + $$ ppr ds ) + Just ds +splitUseProdDmd _ (UCall _ _) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +useCount :: Use u -> Count +useCount Abs = One +useCount (Use One _) = One +useCount _ = Many + + +{- +************************************************************************ +* * + Clean demand for Strictness and Usage +* * +************************************************************************ + +This domain differst from JointDemand in the sense that pure absence +is taken away, i.e., we deal *only* with non-absent demands. + +Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~ +isStrictDmd returns true only of demands that are + both strict + and used +In particular, it is False for , which can and does +arise in, say (#7319) + f x = raise# +Then 'x' is not used, so f gets strictness -> . +Now the w/w generates + fx = let x = absentError "unused" + in raise +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] + +Note [Dealing with call demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Call demands are constructed and deconstructed coherently for +strictness and absence. For instance, the strictness signature for the +following function + +f :: (Int -> (Int, Int)) -> (Int, Bool) +f g = (snd (g 3), True) + +should be: m +-} + +type CleanDemand = JointDmd StrDmd UseDmd + -- A demand that is at least head-strict + +bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand +bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) + = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } + +mkHeadStrict :: CleanDemand -> CleanDemand +mkHeadStrict cd = cd { sd = HeadStr } + +mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand +mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } +mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } + +evalDmd :: Demand +-- Evaluated strictly, and used arbitrarily deeply +evalDmd = JD { sd = Str HeadStr, ud = useTop } + +mkProdDmd :: [Demand] -> CleanDemand +mkProdDmd dx + = JD { sd = mkSProd $ map getStrDmd dx + , ud = mkUProd $ map getUseDmd dx } + +-- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. +mkCallDmd :: CleanDemand -> CleanDemand +mkCallDmd (JD {sd = d, ud = u}) + = JD { sd = mkSCall d, ud = mkUCall One u } + +-- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. +mkCallDmds :: Arity -> CleanDemand -> CleanDemand +mkCallDmds arity cd = iterate mkCallDmd cd !! arity + +-- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap +mkWorkerDemand :: Int -> Demand +mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } + where go 0 = Used + go n = mkUCall One $ go (n-1) + +cleanEvalDmd :: CleanDemand +cleanEvalDmd = JD { sd = HeadStr, ud = Used } + +cleanEvalProdDmd :: Arity -> CleanDemand +cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } + + +{- +************************************************************************ +* * + Demand: Combining Strictness and Usage +* * +************************************************************************ +-} + +type Demand = JointDmd ArgStr ArgUse + +lubDmd :: Demand -> Demand -> Demand +lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `lubArgStr` s2 + , ud = a1 `lubArgUse` a2 } + +bothDmd :: Demand -> Demand -> Demand +bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `bothArgStr` s2 + , ud = a1 `bothArgUse` a2 } + +lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand + +strictApply1Dmd = JD { sd = Str (SCall HeadStr) + , ud = Use Many (UCall One Used) } + +lazyApply1Dmd = JD { sd = Lazy + , ud = Use One (UCall One Used) } + +-- Second argument of catch#: +-- uses its arg at most once, applies it once +-- but is lazy (might not be called at all) +lazyApply2Dmd = JD { sd = Lazy + , ud = Use One (UCall One (UCall One Used)) } + +absDmd :: Demand +absDmd = JD { sd = Lazy, ud = Abs } + +topDmd :: Demand +topDmd = JD { sd = Lazy, ud = useTop } + +botDmd :: Demand +botDmd = JD { sd = strBot, ud = useBot } + +seqDmd :: Demand +seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } + +oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) +oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } +oneifyDmd jd = jd + +isTopDmd :: Demand -> Bool +-- Used to suppress pretty-printing of an uninformative demand +isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True +isTopDmd _ = False + +isAbsDmd :: JointDmd (Str s) (Use u) -> Bool +isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr +isAbsDmd _ = False -- for a bottom demand + +isSeqDmd :: Demand -> Bool +isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True +isSeqDmd _ = False + +isUsedOnce :: JointDmd (Str s) (Use u) -> Bool +isUsedOnce (JD { ud = a }) = case useCount a of + One -> True + Many -> False + +-- More utility functions for strictness +seqDemand :: Demand -> () +seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +isStrictDmd :: JointDmd (Str s) (Use u) -> Bool +-- See Note [Strict demands] +isStrictDmd (JD {ud = Abs}) = False +isStrictDmd (JD {sd = Lazy}) = False +isStrictDmd _ = True + +isWeakDmd :: Demand -> Bool +isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a + +cleanUseDmd_maybe :: Demand -> Maybe UseDmd +cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u +cleanUseDmd_maybe _ = Nothing + +splitFVs :: Bool -- Thunk + -> DmdEnv -> (DmdEnv, DmdEnv) +splitFVs is_thunk rhs_fvs + | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs + -- It's OK to use nonDetFoldUFM_Directly because we + -- immediately forget the ordering by putting the elements + -- in the envs again + | otherwise = partitionVarEnv isWeakDmd rhs_fvs + where + add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) + | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) + | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) + , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) + +data TypeShape = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + +-- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and +-- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. +peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape +peelTsFuns 0 ts = Just ts +peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts +peelTsFuns _ _ = Nothing + +trimToType :: Demand -> TypeShape -> Demand +-- See Note [Trimming a demand to a type] +trimToType (JD { sd = ms, ud = mu }) ts + = JD (go_ms ms ts) (go_mu mu ts) + where + go_ms :: ArgStr -> TypeShape -> ArgStr + go_ms Lazy _ = Lazy + go_ms (Str s) ts = Str (go_s s ts) + + go_s :: StrDmd -> TypeShape -> StrDmd + go_s HyperStr _ = HyperStr + go_s (SCall s) (TsFun ts) = SCall (go_s s ts) + go_s (SProd mss) (TsProd tss) + | equalLength mss tss = SProd (zipWith go_ms mss tss) + go_s _ _ = HeadStr + + go_mu :: ArgUse -> TypeShape -> ArgUse + go_mu Abs _ = Abs + go_mu (Use c u) ts = Use c (go_u u ts) + + go_u :: UseDmd -> TypeShape -> UseDmd + go_u UHead _ = UHead + go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) + go_u (UProd mus) (TsProd tss) + | equalLength mus tss = UProd (zipWith go_mu mus tss) + go_u _ _ = Used + +{- +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a U(U,U) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +Bottom line: we really don't want to have a binder whose demand is more +deeply-nested than its type. There are various ways to tackle this. +When processing (x |> g1), we could "trim" the incoming demand U(U,U) +to match x's type. But I'm currently doing so just at the moment when +we pin a demand on a binder, in GHC.Core.Op.DmdAnal.findBndrDmd. + + +Note [Threshold demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +Threshold usage demand is generated to figure out if +cardinality-instrumented demands of a binding's free variables should +be unleashed. See also [Aggregated demand for cardinality]. + +Note [Replicating polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some demands can be considered as polymorphic. Generally, it is +applicable to such beasts as tops, bottoms as well as Head-Used and +Head-stricts demands. For instance, + +S ~ S(L, ..., L) + +Also, when top or bottom is occurred as a result demand, it in fact +can be expanded to saturate a callee's arity. +-} + +splitProdDmd_maybe :: Demand -> Maybe [Demand] +-- Split a product into its components, iff there is any +-- useful information to be extracted thereby +-- The demand is not necessarily strict! +splitProdDmd_maybe (JD { sd = s, ud = u }) + = case (s,u) of + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing + +{- +************************************************************************ +* * + Termination +* * +************************************************************************ + +Divergence: Dunno + / + Diverges + +In a fixpoint iteration, start from Diverges +-} + +data Divergence + = Diverges -- Definitely diverges + | Dunno -- Might diverge or converge + deriving( Eq, Show ) + +lubDivergence :: Divergence -> Divergence ->Divergence +lubDivergence Diverges r = r +lubDivergence r Diverges = r +lubDivergence Dunno Dunno = Dunno +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +bothDivergence :: Divergence -> Divergence -> Divergence +-- See Note [Asymmetry of 'both' for DmdType and Divergence] +bothDivergence _ Diverges = Diverges +bothDivergence r Dunno = r +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +instance Outputable Divergence where + ppr Diverges = char 'b' + ppr Dunno = empty + +------------------------------------------------------------------------ +-- Combined demand result -- +------------------------------------------------------------------------ + +-- [cprRes] lets us switch off CPR analysis +-- by making sure that everything uses TopRes +topDiv, botDiv :: Divergence +topDiv = Dunno +botDiv = Diverges + +isTopDiv :: Divergence -> Bool +isTopDiv Dunno = True +isTopDiv _ = False + +-- | True if the result diverges or throws an exception +isBotDiv :: Divergence -> Bool +isBotDiv Diverges = True +isBotDiv _ = False + +-- See Notes [Default demand on free variables] +-- and [defaultDmd vs. resTypeArgDmd] +defaultDmd :: Divergence -> Demand +defaultDmd Dunno = absDmd +defaultDmd _ = botDmd -- Diverges + +resTypeArgDmd :: Divergence -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes === (Bot -> BotRes) === ... +-- TopRes === (Top -> TopRes) === ... +-- This function makes that concrete +-- Also see Note [defaultDmd vs. resTypeArgDmd] +resTypeArgDmd Dunno = topDmd +resTypeArgDmd _ = botDmd -- Diverges + +{- +Note [defaultDmd and resTypeArgDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +These functions are similar: They express the demand on something not +explicitly mentioned in the environment resp. the argument list. Yet they are +different: + * Variables not mentioned in the free variables environment are definitely + unused, so we can use absDmd there. + * Further arguments *can* be used, of course. Hence topDmd is used. + + +************************************************************************ +* * + Demand environments and types +* * +************************************************************************ +-} + +type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] + +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + Divergence -- See [Nature of result demand] + +{- +Note [Nature of result demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Divergence contains information about termination (currently distinguishing +definite divergence and no information; it is possible to include definite +convergence here), and CPR information about the result. + +The semantics of this depends on whether we are looking at a DmdType, i.e. the +demand put on by an expression _under a specific incoming demand_ on its +environment, or at a StrictSig describing a demand transformer. + +For a + * DmdType, the termination information is true given the demand it was + generated with, while for + * a StrictSig it holds after applying enough arguments. + +The CPR information, though, is valid after the number of arguments mentioned +in the type is given. Therefore, when forgetting the demand on arguments, as in +dmdAnalRhs, this needs to be considered (via removeDmdTyArgs). + +Consider + b2 x y = x `seq` y `seq` error (show x) +this has a strictness signature of + b +meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but +for "b2 1 2 `seq` ()" we get definite divergence. + +For comparison, + b1 x = x `seq` error (show x) +has a strictness signature of + b +and "b1 1 `seq` ()" is known to terminate. + +Now consider a function h with signature "", and the expression + e1 = h b1 +now h puts a demand of onto its argument, and the demand transformer +turns it into + b +Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not +diverge, and we do not anything being passed to b. + +Note [Asymmetry of 'both' for DmdType and Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'both' for DmdTypes is *asymmetrical*, because there is only one +result! For example, given (e1 e2), we get a DmdType dt1 for e1, use +its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). +Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `bothType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, but + 4. take CPR info from the first argument. + +3 and 4 are implemented in bothDivergence. +-} + +-- Equality needed for fixpoints in GHC.Core.Op.DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 div1) + (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 + -- It's OK to use nonDetUFMToList here because we're testing for + -- equality and even though the lists will be in some arbitrary + -- Unique order, it is the same order for both + && ds1 == ds2 && div1 == div2 + +lubDmdType :: DmdType -> DmdType -> DmdType +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_div + where + n = max (dmdTypeDepth d1) (dmdTypeDepth d2) + (DmdType fv1 ds1 r1) = ensureArgs n d1 + (DmdType fv2 ds2 r2) = ensureArgs n d2 + + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) + lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 + lub_div = lubDivergence r1 r2 + +{- +Note [The need for BothDmdArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, the right argument to bothDmdType, as well as the return value of +dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs +to know about the free variables and termination information, but nothing about +the demand put on arguments, nor cpr information. So we make that explicit by +only passing the relevant information. +-} + +type BothDmdArg = (DmdEnv, Divergence) + +mkBothDmdArg :: DmdEnv -> BothDmdArg +mkBothDmdArg env = (env, Dunno) + +toBothDmdArg :: DmdType -> BothDmdArg +toBothDmdArg (DmdType fv _ r) = (fv, go r) + where + go Dunno = Dunno + go Diverges = Diverges + +bothDmdType :: DmdType -> BothDmdArg -> DmdType +bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'both' for DmdType and Divergence] + -- 'both' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) + ds1 + (r1 `bothDivergence` t2) + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = nonDetUFMToList fv + -- It's OK to use nonDetUFMToList here because we only do it for + -- pretty printing + +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv + +-- nopDmdType is the demand of doing nothing +-- (lazy, absent, no CPR information, no termination information). +-- Note that it is ''not'' the top of the lattice (which would be "may use everything"), +-- so it is (no longer) called topDmd +nopDmdType, botDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topDiv +botDmdType = DmdType emptyDmdEnv [] botDiv + +isTopDmdType :: DmdType -> Bool +isTopDmdType (DmdType env [] res) + | isTopDiv res && isEmptyVarEnv env = True +isTopDmdType _ = False + +mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType +mkDmdType fv ds res = DmdType fv ds res + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds + +-- | This makes sure we can use the demand type with n arguments. +-- It extends the argument list with the correct resTypeArgDmd. +-- It also adjusts the Divergence: Divergence survives additional arguments, +-- CPR information does not (and definite converge also would not). +ensureArgs :: Arity -> DmdType -> DmdType +ensureArgs n d | n == depth = d + | otherwise = DmdType fv ds' r' + where depth = dmdTypeDepth d + DmdType fv ds r = d + + ds' = take n (ds ++ repeat (resTypeArgDmd r)) + r' = case r of -- See [Nature of result demand] + Dunno -> topDiv + _ -> r + + +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv env = seqEltsUFM seqDemandList env + +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) + +-- When e is evaluated after executing an IO action, and d is e's demand, then +-- what of this demand should we consider, given that the IO action can cleanly +-- exit? +-- * We have to kill all strictness demands (i.e. lub with a lazy demand) +-- * We can keep usage information (i.e. lub with an absent demand) +-- * We have to kill definite divergence +-- * We can keep CPR information. +-- See Note [IO hack in the demand analyser] in GHC.Core.Op.DmdAnal +deferAfterIO :: DmdType -> DmdType +deferAfterIO d@(DmdType _ _ res) = + case d `lubDmdType` nopDmdType of + DmdType fv ds _ -> DmdType fv ds (defer_res res) + where + defer_res r@(Dunno {}) = r + defer_res _ = topDiv -- Diverges + +strictenDmd :: Demand -> CleanDemand +strictenDmd (JD { sd = s, ud = u}) + = JD { sd = poke_s s, ud = poke_u u } + where + poke_s Lazy = HeadStr + poke_s (Str s) = s + poke_u Abs = UHead + poke_u (Use _ u) = u + +-- Deferring and peeling + +type DmdShell -- Describes the "outer shell" + -- of a Demand + = JointDmd (Str ()) (Use ()) + +toCleanDmd :: Demand -> (DmdShell, CleanDemand) +-- Splits a Demand into its "shell" and the inner "clean demand" +toCleanDmd (JD { sd = s, ud = u }) + = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) + -- See Note [Analyzing with lazy demand and lambdas] + -- See Note [Analysing with absent demand] + where + (ss, s') = case s of + Str s' -> (Str (), s') + Lazy -> (Lazy, HeadStr) + + (us, u') = case u of + Use c u' -> (Use c (), u') + Abs -> (Abs, Used) + +-- This is used in dmdAnalStar when post-processing +-- a function's argument demand. So we only care about what +-- does to free variables, and whether it terminates. +-- see Note [The need for BothDmdArg] +postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg +postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) + = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) + +postProcessDivergence :: Str () -> Divergence -> Divergence +postProcessDivergence Lazy _ = topDiv +postProcessDivergence _ res = res + +postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv +postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env + | Abs <- us = emptyDmdEnv + -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild + -- of the environment. Be careful, bad things will happen if this doesn't + -- match postProcessDmd (see #13977). + | Str _ <- ss + , Use One _ <- us = env + | otherwise = mapVarEnv (postProcessDmd ds) env + -- For the Absent case just discard all usage information + -- We only processed the thing at all to analyse the body + -- See Note [Always analyse in virgin pass] + +reuseEnv :: DmdEnv -> DmdEnv +reuseEnv = mapVarEnv (postProcessDmd + (JD { sd = Str (), ud = Use Many () })) + +postProcessUnsat :: DmdShell -> DmdType -> DmdType +postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) + = DmdType (postProcessDmdEnv ds fv) + (map (postProcessDmd ds) args) + (postProcessDivergence ss res_ty) + +postProcessDmd :: DmdShell -> Demand -> Demand +postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) + = JD { sd = s', ud = a' } + where + s' = case ss of + Lazy -> Lazy + Str _ -> s + a' = case us of + Abs -> Abs + Use Many _ -> markReusedDmd a + Use One _ -> a + +-- Peels one call level from the demand, and also returns +-- whether it was unsaturated (separately for strictness and usage) +peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) +-- Exploiting the fact that +-- on the strictness side C(B) = B +-- and on the usage side C(U) = U +peelCallDmd (JD {sd = s, ud = u}) + = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) + where + (s', ss) = case s of + SCall s' -> (s', Str ()) + HyperStr -> (HyperStr, Str ()) + _ -> (HeadStr, Lazy) + (u', us) = case u of + UCall c u' -> (u', Use c ()) + _ -> (Used, Use Many ()) + -- The _ cases for usage includes UHead which seems a bit wrong + -- because the body isn't used at all! + -- c.f. the Abs case in toCleanDmd + +-- Peels that multiple nestings of calls clean demand and also returns +-- whether it was unsaturated (separately for strictness and usage +-- see Note [Demands from unsaturated function calls] +peelManyCalls :: Int -> CleanDemand -> DmdShell +peelManyCalls n (JD { sd = str, ud = abs }) + = JD { sd = go_str n str, ud = go_abs n abs } + where + go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer + go_str 0 _ = Str () + go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) + go_str n (SCall d') = go_str (n-1) d' + go_str _ _ = Lazy + + go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least + go_abs 0 _ = Use One () -- one UCall Many in the demand + go_abs n (UCall One d') = go_abs (n-1) d' + go_abs _ _ = Use Many () + +{- +Note [Demands from unsaturated function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a demand transformer d1 -> d2 -> r for f. +If a sufficiently detailed demand is fed into this transformer, +e.g arising from "f x1 x2" in a strict, use-once context, +then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for +the free variable environment) and furthermore the result information r is the +one we want to use. + +An anonymous lambda is also an unsaturated function all (needs one argument, +none given), so this applies to that case as well. + +But the demand fed into f might be less than . There are a few cases: + * Not enough demand on the strictness side: + - In that case, we need to zap all strictness in the demand on arguments and + free variables. + - Furthermore, we remove CPR information. It could be left, but given the incoming + demand is not enough to evaluate so far we just do not bother. + - And finally termination information: If r says that f diverges for sure, + then this holds when the demand guarantees that two arguments are going to + be passed. If the demand is lower, we may just as well converge. + If we were tracking definite convegence, than that would still hold under + a weaker demand than expected by the demand transformer. + * Not enough demand from the usage side: The missing usage can be expanded + using UCall Many, therefore this is subsumed by the third case: + * At least one of the uses has a cardinality of Many. + - Even if f puts a One demand on any of its argument or free variables, if + we call f multiple times, we may evaluate this argument or free variable + multiple times. So forget about any occurrence of "One" in the demand. + +In dmdTransformSig, we call peelManyCalls to find out if we are in any of these +cases, and then call postProcessUnsat to reduce the demand appropriately. + +Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use +peelCallDmd, which peels only one level, but also returns the demand put on the +body of the function. +-} + +peelFV :: DmdType -> Var -> (DmdType, Demand) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) + where + fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables] + dmd = lookupVarEnv fv id `orElse` defaultDmd res + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultDmd res + +{- +Note [Default demand on free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the variable is not mentioned in the environment of a demand type, +its demand is taken to be a result demand of the type. + For the strictness component, + if the result demand is a Diverges, then we use HyperStr + else we use Lazy + For the usage component, we use Absent. +So we use either absDmd or botDmd. + +Also note the equations for lubDivergence (resp. bothDivergence) noted there. + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The insight for analyzing lambdas follows from the fact that for +strictness S = C(L). This polymorphic expansion is critical for +cardinality analysis of the following example: + +{-# NOINLINE build #-} +build g = (g (:) [], g (:) []) + +h c z = build (\x -> + let z1 = z ++ z + in if c + then \y -> x (y ++ z1) + else \y -> x (z1 ++ y)) + +One can see that `build` assigns to `g` demand . +Therefore, when analyzing the lambda `(\x -> ...)`, we +expect each lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand . + +This is achieved by, first, converting the lazy demand L into the +strict S by the second clause of the analysis. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand . The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdType. + +* In a previous incarnation of GHC we needed to be extra careful in the + case of an *unlifted type*, because unlifted values are evaluated + even if they are not used. Example (see #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + However, the argument of toCleanDmd always satisfies the let/app + invariant; so if it is unlifted it is also okForSpeculation, and so + can be evaluated in a short finite time -- and that rules out nasty + cases like the one above. (I'm not quite sure why this was a + problem in an earlier version of GHC, but it isn't now.) + + +************************************************************************ +* * + Demand signatures +* * +************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand +transfomer, namely + + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. +Also see Note [Nature of result demand] for the meaning of a Divergence in a +strictness signature. + +If an Id is applied to less arguments than its arity, it means that +the demand on the function at a call site is weaker than the vanilla +call demand, used for signature inference. Therefore we place a top +demand on all arguments. Otherwise, the demand is specified by Id's +signature. + +For example, the demand transformer described by the demand signature + StrictSig (DmdType {x -> } m) +says that when the function is applied to two arguments, it +unleashes demand on the free var x, on the first arg, +and on the second, then returning a constructor. + +If this same function is applied to one arg, all we can say is that it +uses x with , and its arg with demand . + +Note [Understanding DmdType and StrictSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand types are sound approximations of an expression's semantics relative to +the incoming demand we put the expression under. Consider the following +expression: + + \x y -> x `seq` (y, 2*x) + +Here is a table with demand types resulting from different incoming demands we +put that expression under. Note the monotonicity; a stronger incoming demand +yields a more precise demand type: + + incoming demand | demand type + ---------------------------------------------------- + | {} + | {} + | {} + +Note that in the first example, the depth of the demand type was *higher* than +the arity of the incoming call demand due to the anonymous lambda. +The converse is also possible and happens when we unleash demand signatures. +In @f x y@, the incoming call demand on f has arity 2. But if all we have is a +demand signature with depth 1 for @f@ (which we can safely unleash, see below), +the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. + +So: Demand types are elicited by putting an expression under an incoming (call) +demand, the arity of which can be lower or higher than the depth of the +resulting demand type. +In contrast, a demand signature summarises a function's semantics *without* +immediately specifying the incoming demand it was produced under. Despite StrSig +being a newtype wrapper around DmdType, it actually encodes two things: + + * The threshold (i.e., minimum arity) to unleash the signature + * A demand type that is sound to unleash when the minimum arity requirement is + met. + +Here comes the subtle part: The threshold is encoded in the wrapped demand +type's depth! So in mkStrictSigForArity we make sure to trim the list of +argument demands to the given threshold arity. Call sites will make sure that +this corresponds to the arity of the call demand that elicited the wrapped +demand type. See also Note [What are demand signatures?] in GHC.Core.Op.DmdAnal. + +Besides trimming argument demands, mkStrictSigForArity will also trim CPR +information if necessary. +-} + +-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe +-- to unleash. Better construct this through 'mkStrictSigForArity'. +-- See Note [Understanding DmdType and StrictSig] +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig :: StrictSig -> SDoc +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res + +-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' +-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] +mkStrictSigForArity :: Arity -> DmdType -> StrictSig +mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) + +mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig +mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) + +splitStrictSig :: StrictSig -> ([Demand], Divergence) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +increaseStrictSigArity :: Int -> StrictSig -> StrictSig +-- ^ Add extra arguments to a strictness signature. +-- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument +-- demands and leaves CPR info intact. +increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | isTopDmdType dmd_ty = sig + | arity_increase == 0 = sig + | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" + <+> text "negative arity increase" + <+> ppr arity_increase ) + nopSig + | otherwise = StrictSig (DmdType env dmds' res) + where + dmds' = replicate arity_increase topDmd ++ dmds + +etaExpandStrictSig :: Arity -> StrictSig -> StrictSig +-- ^ We are expanding (\x y. e) to (\x y z. e z). +-- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if +-- necessary, potentially destroying the signature's CPR property. +etaExpandStrictSig arity (StrictSig dmd_ty) + | arity < dmdTypeDepth dmd_ty + -- an arity decrease must zap the whole signature, because it was possibly + -- computed for a higher incoming call demand. + = nopSig + | otherwise + = StrictSig $ ensureArgs arity dmd_ty + +isTopSig :: StrictSig -> Bool +isTopSig (StrictSig ty) = isTopDmdType ty + +hasDemandEnvSig :: StrictSig -> Bool +hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) + +strictSigDmdEnv :: StrictSig -> DmdEnv +strictSigDmdEnv (StrictSig (DmdType env _ _)) = env + +-- | True if the signature diverges or throws an exception +isBottomingSig :: StrictSig -> Bool +isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res + +nopSig, botSig :: StrictSig +nopSig = StrictSig nopDmdType +botSig = StrictSig botDmdType + +cprProdSig :: Arity -> StrictSig +cprProdSig _arity = nopSig + +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty + +dmdTransformSig :: StrictSig -> CleanDemand -> DmdType +-- (dmdTransformSig fun_sig dmd) considers a call to a function whose +-- signature is fun_sig, with demand dmd. We return the demand +-- that the function places on its context (eg its args) +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd + = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty + -- see Note [Demands from unsaturated function calls] + +dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType +-- Same as dmdTransformSig but for a data constructor (worker), +-- which has a special kind of demand transformer. +-- If the constructor is saturated, we feed the demand on +-- the result into the constructor arguments. +dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) + (JD { sd = str, ud = abs }) + | Just str_dmds <- go_str arity str + , Just abs_dmds <- go_abs arity abs + = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res + -- Must remember whether it's a product, hence con_res, not TopRes + + | otherwise -- Not saturated + = nopDmdType + where + go_str 0 dmd = splitStrProdDmd arity dmd + go_str n (SCall s') = go_str (n-1) s' + go_str n HyperStr = go_str (n-1) HyperStr + go_str _ _ = Nothing + + go_abs 0 dmd = splitUseProdDmd arity dmd + go_abs n (UCall One u') = go_abs (n-1) u' + go_abs _ _ = Nothing + +dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType +-- Like dmdTransformDataConSig, we have a special demand transformer +-- for dictionary selectors. If the selector is saturated (ie has one +-- argument: the dictionary), we feed the demand on the result into +-- the indicated dictionary component. +dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd + | (cd',defer_use) <- peelCallDmd cd + , Just jds <- splitProdDmd_maybe dict_dmd + = postProcessUnsat defer_use $ + DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv + | otherwise + = nopDmdType -- See Note [Demand transformer for a dictionary selector] + where + enhance cd old | isAbsDmd old = old + | otherwise = mkOnceUsedDmd cd -- This is the one! + +dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" + +{- +Note [Demand transformer for a dictionary selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' +into the appropriate field of the dictionary. What *is* the appropriate field? +We just look at the strictness signature of the class op, which will be +something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. + +For single-method classes, which are represented by newtypes the signature +of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. +That's fine: if we are doing strictness analysis we are also doing inlining, +so we'll have inlined 'op' into a cast. So we can bale out in a conservative +way, returning nopDmdType. + +It is (just.. #8329) possible to be running strictness analysis *without* +having inlined class ops from single-method classes. Suppose you are using +ghc --make; and the first module has a local -O0 flag. So you may load a class +without interface pragmas, ie (currently) without an unfolding for the class +ops. Now if a subsequent module in the --make sweep has a local -O flag +you might do strictness analysis, but there is no inlining for the class op. +This is weird, so I'm not worried about whether this optimises brilliantly; but +it should not fall over. +-} + +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- See Note [Computing one-shot info] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + | unsaturated_call = [] + | otherwise = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +-- saturatedByOneShots n C1(C1(...)) = True, +-- <=> +-- there are at least n nested C1(..) calls +-- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap +saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots n (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go n arg_usg + _ -> False + where + go 0 _ = True + go n (UCall One u) = go (n-1) u + go _ _ = False + +argOneShots :: Demand -- depending on saturation + -> [OneShotInfo] +argOneShots (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = OneShotLam : go u + go (UCall Many u) = NoOneShotInfo : go u + go _ = [] + +{- Note [Computing one-shot info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. +-} + +-- | Returns true if an application to n args +-- would diverge or throw an exception +-- See Note [Unsaturated applications] +appIsBottom :: StrictSig -> Int -> Bool +appIsBottom (StrictSig (DmdType _ ds res)) n + | isBotDiv res = not $ lengthExceeds ds n +appIsBottom _ _ = False + +{- +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a function having bottom as its demand result is applied to a less +number of arguments than its syntactic arity, we cannot say for sure +that it is going to diverge. This is the reason why we use the +function appIsBottom, which, given a strictness signature and a number +of arguments, says conservatively if the function is going to diverge +or not. +-} + +zapUsageEnvSig :: StrictSig -> StrictSig +-- Remove the usage environment from the demand +zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r + +zapUsageDemand :: Demand -> Demand +-- Remove the usage info, but not the strictness info, from the demand +zapUsageDemand = kill_usage $ KillFlags + { kf_abs = True + , kf_used_once = True + , kf_called_once = True + } + +-- | Remove all 1* information (but not C1 information) from the demand +zapUsedOnceDemand :: Demand -> Demand +zapUsedOnceDemand = kill_usage $ KillFlags + { kf_abs = False + , kf_used_once = True + , kf_called_once = False + } + +-- | Remove all 1* information (but not C1 information) from the strictness +-- signature +zapUsedOnceSig :: StrictSig -> StrictSig +zapUsedOnceSig (StrictSig (DmdType env ds r)) + = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) + +data KillFlags = KillFlags + { kf_abs :: Bool + , kf_used_once :: Bool + , kf_called_once :: Bool + } + +kill_usage :: KillFlags -> Demand -> Demand +kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} + +zap_musg :: KillFlags -> ArgUse -> ArgUse +zap_musg kfs Abs + | kf_abs kfs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) + | kf_used_once kfs = Use Many (zap_usg kfs u) + | otherwise = Use c (zap_usg kfs u) + +zap_usg :: KillFlags -> UseDmd -> UseDmd +zap_usg kfs (UCall c u) + | kf_called_once kfs = UCall Many (zap_usg kfs u) + | otherwise = UCall c (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u + +-- If the argument is a used non-newtype dictionary, give it strict +-- demand. Also split the product type & demand and recur in order to +-- similarly strictify the argument's contained used non-newtype +-- superclass dictionaries. We use the demand as our recursive measure +-- to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty dmd = case getUseDmd dmd of + Use n _ | + Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) + <- splitDataProductType_maybe ty, + not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary + -> seqDmd `bothDmd` -- main idea: ensure it's strict + case splitProdDmd_maybe dmd of + -- superclass cycles should not be a problem, since the demand we are + -- consuming would also have to be infinite in order for us to diverge + Nothing -> dmd -- no components have interesting demand, so stop + -- looking for superclass dicts + Just dmds + | all (not . isAbsDmd) dmds -> evalDmd + -- abstract to strict w/ arbitrary component use, since this + -- smells like reboxing; results in CBV boxed + -- + -- TODO revisit this if we ever do boxity analysis + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of + JD {sd = s,ud = a} -> JD (Str s) (Use n a) + -- TODO could optimize with an aborting variant of zipWith since + -- the superclass dicts are always a prefix + _ -> dmd -- unused or not a dictionary + +strictifyDmd :: Demand -> Demand +strictifyDmd dmd@(JD { sd = str }) + = dmd { sd = str `bothArgStr` Str HeadStr } + +{- +Note [HyperStr and Use demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The information "HyperStr" needs to be in the strictness signature, and not in +the demand signature, because we still want to know about the demand on things. Consider + + f (x,y) True = error (show x) + f (x,y) False = x+1 + +The signature of f should be m. If we were not +distinguishing the uses on x and y in the True case, we could either not figure +out how deeply we can unpack x, or that we do not have to pass y. + + +************************************************************************ +* * + Serialisation +* * +************************************************************************ +-} + +instance Binary StrDmd where + put_ bh HyperStr = do putByte bh 0 + put_ bh HeadStr = do putByte bh 1 + put_ bh (SCall s) = do putByte bh 2 + put_ bh s + put_ bh (SProd sx) = do putByte bh 3 + put_ bh sx + get bh = do + h <- getByte bh + case h of + 0 -> do return HyperStr + 1 -> do return HeadStr + 2 -> do s <- get bh + return (SCall s) + _ -> do sx <- get bh + return (SProd sx) + +instance Binary ArgStr where + put_ bh Lazy = do + putByte bh 0 + put_ bh (Str s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return Lazy + _ -> do s <- get bh + return $ Str s + +instance Binary Count where + put_ bh One = do putByte bh 0 + put_ bh Many = do putByte bh 1 + + get bh = do h <- getByte bh + case h of + 0 -> return One + _ -> return Many + +instance Binary ArgUse where + put_ bh Abs = do + putByte bh 0 + put_ bh (Use c u) = do + putByte bh 1 + put_ bh c + put_ bh u + + get bh = do + h <- getByte bh + case h of + 0 -> return Abs + _ -> do c <- get bh + u <- get bh + return $ Use c u + +instance Binary UseDmd where + put_ bh Used = do + putByte bh 0 + put_ bh UHead = do + putByte bh 1 + put_ bh (UCall c u) = do + putByte bh 2 + put_ bh c + put_ bh u + put_ bh (UProd ux) = do + putByte bh 3 + put_ bh ux + + get bh = do + h <- getByte bh + case h of + 0 -> return $ Used + 1 -> return $ UHead + 2 -> do c <- get bh + u <- get bh + return (UCall c u) + _ -> do ux <- get bh + return (UProd ux) + +instance (Binary s, Binary u) => Binary (JointDmd s u) where + put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y + get bh = do + x <- get bh + y <- get bh + return $ JD { sd = x, ud = y } + +instance Binary StrictSig where + put_ bh (StrictSig aa) = do + put_ bh aa + get bh = do + aa <- get bh + return (StrictSig aa) + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) + = do put_ bh ds + put_ bh dr + get bh + = do ds <- get bh + dr <- get bh + return (DmdType emptyDmdEnv ds dr) + +instance Binary Divergence where + put_ bh Dunno = putByte bh 0 + put_ bh Diverges = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return Dunno + _ -> return Diverges } diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/FieldLabel.hs @@ -0,0 +1,132 @@ +{- +% +% (c) Adam Gundry 2013-2015 +% + +This module defines the representation of FieldLabels as stored in +TyCons. As well as a selector name, these have some extra structure +to support the DuplicateRecordFields extension. + +In the normal case (with NoDuplicateRecordFields), a datatype like + + data T = MkT { foo :: Int } + +has + + FieldLabel { flLabel = "foo" + , flIsOverloaded = False + , flSelector = foo }. + +In particular, the Name of the selector has the same string +representation as the label. If DuplicateRecordFields +is enabled, however, the same declaration instead gives + + FieldLabel { flLabel = "foo" + , flIsOverloaded = True + , flSelector = $sel:foo:MkT }. + +Now the name of the selector ($sel:foo:MkT) does not match the label of +the field (foo). We must be careful not to show the selector name to +the user! The point of mangling the selector name is to allow a +module to define the same field label in different datatypes: + + data T = MkT { foo :: Int } + data U = MkU { foo :: Bool } + +Now there will be two FieldLabel values for 'foo', one in T and one in +U. They share the same label (FieldLabelString), but the selector +functions differ. + +See also Note [Representing fields in AvailInfo] in GHC.Types.Avail. + +Note [Why selector names include data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As explained above, a selector name includes the name of the first +data constructor in the type, so that the same label can appear +multiple times in the same module. (This is irrespective of whether +the first constructor has that field, for simplicity.) + +We use a data constructor name, rather than the type constructor name, +because data family instances do not have a representation type +constructor name generated until relatively late in the typechecking +process. + +Of course, datatypes with no constructors cannot have any fields. + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Types.FieldLabel + ( FieldLabelString + , FieldLabelEnv + , FieldLbl(..) + , FieldLabel + , mkFieldLabelOccs + ) +where + +import GhcPrelude + +import GHC.Types.Name.Occurrence +import GHC.Types.Name + +import FastString +import FastStringEnv +import Outputable +import Binary + +import Data.Data + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +type FieldLabelString = FastString + +-- | A map from labels to all the auxiliary information +type FieldLabelEnv = DFastStringEnv FieldLabel + + +type FieldLabel = FieldLbl Name + +-- | Fields in an algebraic record type +data FieldLbl a = FieldLabel { + flLabel :: FieldLabelString, -- ^ User-visible label of the field + flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on + -- in the defining module for this datatype? + flSelector :: a -- ^ Record selector function + } + deriving (Eq, Functor, Foldable, Traversable) +deriving instance Data a => Data (FieldLbl a) + +instance Outputable a => Outputable (FieldLbl a) where + ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) + +instance Binary a => Binary (FieldLbl a) where + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + ab <- get bh + ac <- get bh + ad <- get bh + return (FieldLabel ab ac ad) + + +-- | Record selector OccNames are built from the underlying field name +-- and the name of the first data constructor of the type, to support +-- duplicate record field names. +-- See Note [Why selector names include data constructors]. +mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName +mkFieldLabelOccs lbl dc is_overloaded + = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = sel_occ } + where + str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc + sel_occ | is_overloaded = mkRecFldSelOcc str + | otherwise = mkVarOccFS lbl diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/ForeignCall.hs @@ -0,0 +1,348 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Foreign]{Foreign calls} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.ForeignCall ( + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), + ) where + +import GhcPrelude + +import FastString +import Binary +import Outputable +import GHC.Types.Module +import GHC.Types.Basic ( SourceText, pprWithSourceText ) + +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsubsection{Data types} +* * +************************************************************************ +-} + +newtype ForeignCall = CCall CCallSpec + deriving Eq + +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + +data Safety + = PlaySafe -- Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- None of the above can happen; the call will return + -- without interacting with the runtime system at all + deriving ( Eq, Show, Data ) + -- Show used just for Show Lex.Token, I think + +instance Outputable Safety where + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" + +playSafe :: Safety -> Bool +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False + +{- +************************************************************************ +* * +\subsubsection{Calling C} +* * +************************************************************************ +-} + +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + SourceText -- of the CLabelString. + -- See note [Pragma source text] in GHC.Types.Basic + CLabelString -- C Name of exported function + CCallConv + deriving Data + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + +-- The call target: + +-- | How to call a particular function in C-land. +data CCallTarget + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + SourceText -- of the CLabelString. + -- See note [Pragma source text] in GHC.Types.Basic + CLabelString -- C-land name of label. + + (Maybe UnitId) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports + | DynamicTarget + + deriving( Eq, Data ) + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget _ = False + +{- +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +stdcall: Caller allocates parameters, callee deallocates. + Function name has @N after it, where N is number of arg bytes + e.g. _Foo@8. This convention is x86 (win32) specific. + +See: http://www.programmersheaven.com/2/Calling-conventions +-} + +-- any changes here should be replicated in the CallConv type in template haskell +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv + deriving (Eq, Data) + +instance Outputable CCallConv where + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" +ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" +ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" + +{- +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): +-} + +ccallConvAttribute :: CCallConv -> SDoc +ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" +ccallConvAttribute CCallConv = empty +ccallConvAttribute CApiConv = empty +ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" + +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + +-- Printing into C files: + +instance Outputable CExportSpec where + ppr (CExportStatic _ str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ whenPprDebug callconv, ppr_fun fun ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_GC" + | otherwise = empty + + ppr_fun (StaticTarget st _fn mPkgId isFun) + = text (if isFun then "__pkg_ccall" + else "__pkg_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <+> (pprWithSourceText st empty) + + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + +-- The filename for a C header file +-- Note [Pragma source text] in GHC.Types.Basic +data Header = Header SourceText FastString + deriving (Eq, Data) + +instance Outputable Header where + ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) + +-- | A C type, used in CAPI FFI calls +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, +-- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', +-- 'ApiAnnotation.AnnClose' @'\#-}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic + (Maybe Header) -- header to include for this type + (SourceText,FastString) -- the type itself + deriving (Eq, Data) + +instance Outputable CType where + ppr (CType stp mh (stct,ct)) + = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc + <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h + +{- +************************************************************************ +* * +\subsubsection{Misc} +* * +************************************************************************ +-} + +instance Binary ForeignCall where + put_ bh (CCall aa) = put_ bh aa + get bh = do aa <- get bh; return (CCall aa) + +instance Binary Safety where + put_ bh PlaySafe = do + putByte bh 0 + put_ bh PlayInterruptible = do + putByte bh 1 + put_ bh PlayRisky = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible + _ -> do return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic ss aa ab) = do + put_ bh ss + put_ bh aa + put_ bh ab + get bh = do + ss <- get bh + aa <- get bh + ab <- get bh + return (CExportStatic ss aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget ss aa ab ac) = do + putByte bh 0 + put_ bh ss + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + aa <- get bh + ab <- get bh + ac <- get bh + return (StaticTarget ss aa ab ac) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + put_ bh PrimCallConv = do + putByte bh 2 + put_ bh CApiConv = do + putByte bh 3 + put_ bh JavaScriptCallConv = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + 1 -> do return StdCallConv + 2 -> do return PrimCallConv + 3 -> do return CApiConv + _ -> do return JavaScriptCallConv + +instance Binary CType where + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh + fs <- get bh + return (CType s mh fs) + +instance Binary Header where + put_ bh (Header s h) = put_ bh s >> put_ bh h + get bh = do s <- get bh + h <- get bh + return (Header s h) diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Id.hs @@ -0,0 +1,971 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Id]{@Ids@: Value and constructor identifiers} +-} + +{-# LANGUAGE CPP #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a +-- 'GHC.Core.TyCo.Rep.Type' and some additional details (a 'IdInfo.IdInfo' and +-- one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that are added, +-- modified and inspected by various compiler passes. These 'Var.Var' names +-- may either be global or local, see "Var#globalvslocal" +-- +-- * 'Var.Var': see "Var#name_types" + +module GHC.Types.Id ( + -- * The main types + Var, Id, isId, + + -- * In and Out variants + InVar, InId, + OutVar, OutId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, + mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, + mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, + mkUserLocal, mkUserLocalOrCoVar, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkWorkerId, + + -- ** Taking an Id apart + idName, idType, idUnique, idInfo, idDetails, + recordSelectorTyCon, + + -- ** Modifying an Id + setIdName, setIdUnique, GHC.Types.Id.setIdType, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapIdUsedOnceInfo, zapIdTailCallInfo, + zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, + transferPolyIdInfo, + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, + isStrictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isPatSynRecordSelector, + isDataConRecordSelector, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isDataConWrapId, isDataConWrapId_maybe, + isDataConId_maybe, + idDataCon, + isConLikeId, isBottomingId, idIsFrom, + hasNoBinding, + + -- ** Join variables + JoinId, isJoinId, isJoinId_maybe, idJoinArity, + asJoinId, asJoinId_maybe, zapJoinId, + + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + idInlineActivation, setInlineActivation, idRuleMatchInfo, + + -- ** One-shot lambdas + isOneShotBndr, isProbablyOneShotLambda, + setOneShotLambda, clearOneShotLambda, + updOneShotInfo, setIdOneShotInfo, + isStateHackType, stateHackOneShot, typeOneShot, + + -- ** Reading 'IdInfo' fields + idArity, + idCallArity, idFunRepArity, + idUnfolding, realIdUnfolding, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, + idOneShotInfo, idStateHackOneShotInfo, + idOccInfo, + isNeverLevPolyId, + + -- ** Writing 'IdInfo' fields + setIdUnfolding, setCaseBndrEvald, + setIdArity, + setIdCallArity, + + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, + + setIdDemandInfo, + setIdStrictness, + setIdCprInfo, + + idDemandInfo, + idStrictness, + idCprInfo, + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, + isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) + +import GHC.Types.Id.Info +import GHC.Types.Basic + +-- Imported and re-exported +import GHC.Types.Var( Id, CoVar, JoinId, + InId, InVar, + OutId, OutVar, + idInfo, idDetails, setIdDetails, globaliseId, + isId, isLocalId, isGlobalId, isExportedId ) +import qualified GHC.Types.Var as Var + +import GHC.Core.Type +import GHC.Types.RepType +import TysPrim +import GHC.Core.DataCon +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name +import GHC.Types.Module +import GHC.Core.Class +import {-# SOURCE #-} PrimOp (PrimOp) +import GHC.Types.ForeignCall +import Maybes +import GHC.Types.SrcLoc +import Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import FastString +import Util + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfolding`, + `setIdArity`, + `setIdCallArity`, + `setIdOccInfo`, + `setIdOneShotInfo`, + + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo`, + + `setIdDemandInfo`, + `setIdStrictness`, + `setIdCprInfo`, + + `asJoinId`, + `asJoinId_maybe` + +{- +************************************************************************ +* * +\subsection{Basic Id manipulation} +* * +************************************************************************ +-} + +idName :: Id -> Name +idName = Var.varName + +idUnique :: Id -> Unique +idUnique = Var.varUnique + +idType :: Id -> Kind +idType = Var.varType + +setIdName :: Id -> Name -> Id +setIdName = Var.setVarName + +setIdUnique :: Id -> Unique -> Id +setIdUnique = Var.setVarUnique + +-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and +-- reduce space usage +setIdType :: Id -> Type -> Id +setIdType id ty = seqType ty `seq` Var.setVarType id ty + +setIdExported :: Id -> Id +setIdExported = Var.setIdExported + +setIdNotExported :: Id -> Id +setIdNotExported = Var.setIdNotExported + +localiseId :: Id -> Id +-- Make an Id with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | ASSERT( isId id ) isLocalId id && isInternalName name + = id + | otherwise + = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) + where + name = idName id + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo = Var.lazySetIdInfo + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = info `seq` (lazySetIdInfo id info) + -- Try to avoid space leaks by seq'ing + +modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) + +-- maybeModifyIdInfo tries to avoid unnecessary thrashing +maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id +maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info +maybeModifyIdInfo Nothing id = id + +{- +************************************************************************ +* * +\subsection{Simple Id construction} +* * +************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +Note [Free type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we cached the free type variables of the type of an Id +at the root of the type in a TyNote. The idea was to avoid repeating +the free-type-variable calculation. But it turned out to slow down +the compiler overall. I don't quite know why; perhaps finding free +type variables of an Id isn't all that common whereas applying a +substitution (which changes the free type variables) is more common. +Anyway, we removed it in March 2008. +-} + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar + +-- | Make a global 'Id' without any extra information at all +mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo + +-- | Make a global 'Id' with no global information but some generic 'IdInfo' +mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo = mkGlobalId VanillaId + + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkLocalId :: HasDebugCallStack => Name -> Type -> Id +mkLocalId name ty = ASSERT( not (isCoVarType ty) ) + mkLocalIdWithInfo name ty vanillaIdInfo + +-- | Make a local CoVar +mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar name ty + = ASSERT( isCoVarType ty ) + Var.mkLocalVar CoVarId name ty vanillaIdInfo + +-- | Like 'mkLocalId', but checks the type to see if it should make a covar +mkLocalIdOrCoVar :: Name -> Type -> Id +mkLocalIdOrCoVar name ty + | isCoVarType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name ty + + -- proper ids only; no covars! +mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) ) + Var.mkLocalVar VanillaId name ty info + -- Note [Free type variables] + +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo + -- Note [Free type variables] + +mkExportedVanillaId :: Name -> Type -> Id +mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo + -- Note [Free type variables] + + +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air +mkSysLocal :: FastString -> Unique -> Type -> Id +mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkSystemVarName uniq fs) ty + +-- | Like 'mkSysLocal', but checks to see if we have a covar type +mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id +mkSysLocalOrCoVar fs uniq ty + = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty + +mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) + +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalOrCoVarM fs ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) + +-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize +mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkInternalName uniq occ loc) ty + +-- | Like 'mkUserLocal', but checks if we have a coercion type +mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty + +{- +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +-} + +-- | Workers get local names. "CoreTidy" will externalise these if necessary +mkWorkerId :: Unique -> Id -> Type -> Id +mkWorkerId uniq unwrkr ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty + +-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty + -- "OrCoVar" since this is used in a superclass selector, + -- and "~" and "~~" have coercion "superclasses". + +-- | Create a template local for a series of types +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals = mkTemplateLocalsNum 1 + +-- | Create a template local for a series of type, but start from a specified template local +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +{- Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - Pattern-synonym matcher and builder Ids + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIds, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. GHC.Core.FVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst). Lacking this we + can get an out-of-date unfolding, which can in turn make the + simplifier go into an infinite loop (#9857) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in GHC.Iface.Tidy. + +************************************************************************ +* * +\subsection{Special Ids} +* * +************************************************************************ +-} + +-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. +recordSelectorTyCon :: Id -> RecSelParent +recordSelectorTyCon id + = case Var.idDetails id of + RecSelId { sel_tycon = parent } -> parent + _ -> panic "recordSelectorTyCon" + + +isRecordSelector :: Id -> Bool +isNaughtyRecordSelector :: Id -> Bool +isPatSynRecordSelector :: Id -> Bool +isDataConRecordSelector :: Id -> Bool +isPrimOpId :: Id -> Bool +isFCallId :: Id -> Bool +isDataConWorkId :: Id -> Bool +isDataConWrapId :: Id -> Bool +isDFunId :: Id -> Bool + +isClassOpId_maybe :: Id -> Maybe Class +isPrimOpId_maybe :: Id -> Maybe PrimOp +isFCallId_maybe :: Id -> Maybe ForeignCall +isDataConWorkId_maybe :: Id -> Maybe DataCon +isDataConWrapId_maybe :: Id -> Maybe DataCon + +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True + _ -> False + +isDataConRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelData _} -> True + _ -> False + +isPatSynRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelPatSyn _} -> True + _ -> False + +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n + _ -> False + +isClassOpId_maybe id = case Var.idDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + +isPrimOpId id = case Var.idDetails id of + PrimOpId _ -> True + _ -> False + +isDFunId id = case Var.idDetails id of + DFunId {} -> True + _ -> False + +isPrimOpId_maybe id = case Var.idDetails id of + PrimOpId op -> Just op + _ -> Nothing + +isFCallId id = case Var.idDetails id of + FCallId _ -> True + _ -> False + +isFCallId_maybe id = case Var.idDetails id of + FCallId call -> Just call + _ -> Nothing + +isDataConWorkId id = case Var.idDetails id of + DataConWorkId _ -> True + _ -> False + +isDataConWorkId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + _ -> Nothing + +isDataConWrapId id = case Var.idDetails id of + DataConWrapId _ -> True + _ -> False + +isDataConWrapId_maybe id = case Var.idDetails id of + DataConWrapId con -> Just con + _ -> Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + _ -> Nothing + +isJoinId :: Var -> Bool +-- It is convenient in GHC.Core.Op.SetLevels.lvlMFE to apply isJoinId +-- to the free vars of an expression, so it's convenient +-- if it returns False for type variables +isJoinId id + | isId id = case Var.idDetails id of + JoinId {} -> True + _ -> False + | otherwise = False + +isJoinId_maybe :: Var -> Maybe JoinArity +isJoinId_maybe id + | isId id = ASSERT2( isId id, ppr id ) + case Var.idDetails id of + JoinId arity -> Just arity + _ -> Nothing + | otherwise = Nothing + +idDataCon :: Id -> DataCon +-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. +-- +-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker +idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) + +hasNoBinding :: Id -> Bool +-- ^ Returns @True@ of an 'Id' which may not have a +-- binding, even though it is defined in this module. + +-- Data constructor workers used to be things of this kind, but +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. +-- +-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. +-- for the history of this. +-- +-- Note that CorePrep currently eta expands things no-binding things and this +-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things +-- in CorePrep] in CorePrep for details. +-- +-- EXCEPT: unboxed tuples, which definitely have no binding +hasNoBinding id = case Var.idDetails id of + PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc + _ -> isCompulsoryUnfolding (idUnfolding id) + -- See Note [Levity-polymorphic Ids] + +isImplicitId :: Id -> Bool +-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other +-- declarations, so we don't need to put its signature in an interface +-- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case Var.idDetails id of + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True + -- These are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + _ -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) + +{- Note [Levity-polymorphic Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some levity-polymorphic Ids must be applied and inlined, not left +un-saturated. Example: + unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b + +This has a compulsory unfolding because we can't lambda-bind those +arguments. But the compulsory unfolding may leave levity-polymorphic +lambdas if it is not applied to enough arguments; e.g. (#14561) + bad :: forall (a :: TYPE r). a -> a + bad = unsafeCoerce# + +The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop. +And we want that magic to apply to levity-polymorphic compulsory-inline things. +The easiest way to do this is for hasNoBinding to return True of all things +that have compulsory unfolding. Some Ids with a compulsory unfolding also +have a binding, but it does not harm to say they don't here, and its a very +simple way to fix #14561. +-} + +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead + +{- +************************************************************************ +* * + Join variables +* * +************************************************************************ +-} + +idJoinArity :: JoinId -> JoinArity +idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) + +asJoinId :: Id -> JoinArity -> JoinId +asJoinId id arity = WARN(not (isLocalId id), + text "global id being marked as join var:" <+> ppr id) + WARN(not (is_vanilla_or_join id), + ppr id <+> pprIdDetails (idDetails id)) + id `setIdDetails` JoinId arity + where + is_vanilla_or_join id = case Var.idDetails id of + VanillaId -> True + JoinId {} -> True + _ -> False + +zapJoinId :: Id -> Id +-- May be a regular id already +zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) + -- Core Lint may complain if still marked + -- as AlwaysTailCalled + | otherwise = jid + +asJoinId_maybe :: Id -> Maybe JoinArity -> Id +asJoinId_maybe id (Just arity) = asJoinId id arity +asJoinId_maybe id Nothing = zapJoinId id + +{- +************************************************************************ +* * +\subsection{IdInfo stuff} +* * +************************************************************************ +-} + + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +idCallArity :: Id -> Arity +idCallArity id = callArityInfo (idInfo id) + +setIdCallArity :: Id -> Arity -> Id +setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id + +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + +-- | Returns true if an application to n args would diverge +isBottomingId :: Var -> Bool +isBottomingId v + | isId v = isBottomingSig (idStrictness v) + | otherwise = False + +-- | Accesses the 'Id''s 'strictnessInfo'. +idStrictness :: Id -> StrictSig +idStrictness id = strictnessInfo (idInfo id) + +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id + +idCprInfo :: Id -> CprSig +idCprInfo id = cprInfo (idInfo id) + +setIdCprInfo :: Id -> CprSig -> Id +setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id + +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id + +-- | This predicate says whether the 'Id' has a strict demand placed on it or +-- has a type such that it can always be evaluated strictly (i.e an +-- unlifted type, as of GHC 7.6). We need to +-- check separately whether the 'Id' has a so-called \"strict type\" because if +-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict +-- type, we still want @isStrictId id@ to be @True@. +isStrictId :: Id -> Bool +isStrictId id + = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + not (isJoinId id) && ( + (isStrictType (idType id)) || + -- Take the best of both strictnesses - old and new + (isStrictDmd (idDemandInfo id)) + ) + + --------------------------------- + -- UNFOLDING +idUnfolding :: Id -> Unfolding +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id + +setCaseBndrEvald :: StrictnessMark -> Id -> Id +-- Used for variables bound by a case expressions, both the case-binder +-- itself, and any pattern-bound variables that are argument of a +-- strict constructor. It just marks the variable as already-evaluated, +-- so that (for example) a subsequent 'seq' can be dropped +setCaseBndrEvald str id + | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding + | otherwise = id + + --------------------------------- + -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in GHC.Types.Id.Info + +idSpecialisation :: Id -> RuleInfo +idSpecialisation id = ruleInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = ruleInfoRules (idSpecialisation id) + +idHasRules :: Id -> Bool +idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) + +setIdSpecialisation :: Id -> RuleInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- Occurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` noOccInfo + +{- + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. +-} + +idInlinePragma :: Id -> InlinePragma +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragma -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id + +idInlineActivation :: Id -> Activation +idInlineActivation id = inlinePragmaActivation (idInlinePragma id) + +setInlineActivation :: Id -> Activation -> Id +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) + +idRuleMatchInfo :: Id -> RuleMatchInfo +idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) + +isConLikeId :: Id -> Bool +isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) + +{- + --------------------------------- + -- ONE-SHOT LAMBDAS +-} + +idOneShotInfo :: Id -> OneShotInfo +idOneShotInfo id = oneShotInfo (idInfo id) + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in GHC.Core.Arity +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = stateHackOneShot + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in GHC.Core.Arity +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +-- | Should we apply the state hack to values of this 'Type'? +stateHackOneShot :: OneShotInfo +stateHackOneShot = OneShotLam + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = stateHackOneShot + | otherwise = NoOneShotInfo + +isStateHackType :: Type -> Bool +isStateHackType ty + | hasNoStateHack unsafeGlobalDynFlags + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + +isProbablyOneShotLambda :: Id -> Bool +isProbablyOneShotLambda id = case idStateHackOneShotInfo id of + OneShotLam -> True + NoOneShotInfo -> False + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id + +setIdOneShotInfo :: Id -> OneShotInfo -> Id +setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id + +updOneShotInfo :: Id -> OneShotInfo -> Id +-- Combine the info in the Id with new info +updOneShotInfo id one_shot + | do_upd = setIdOneShotInfo id one_shot + | otherwise = id + where + do_upd = case (idOneShotInfo id, one_shot) of + (NoOneShotInfo, _) -> True + (OneShotLam, _) -> False + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes + +zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id + +zapLamIdInfo :: Id -> Id +zapLamIdInfo = zapInfo zapLamInfo + +zapFragileIdInfo :: Id -> Id +zapFragileIdInfo = zapInfo zapFragileInfo + +zapIdDemandInfo :: Id -> Id +zapIdDemandInfo = zapInfo zapDemandInfo + +zapIdUsageInfo :: Id -> Id +zapIdUsageInfo = zapInfo zapUsageInfo + +zapIdUsageEnvInfo :: Id -> Id +zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo + +zapIdUsedOnceInfo :: Id -> Id +zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo + +zapIdTailCallInfo :: Id -> Id +zapIdTailCallInfo = zapInfo zapTailCallInfo + +zapStableUnfolding :: Id -> Id +zapStableUnfolding id + | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding + | otherwise = id + +{- +Note [transferPolyIdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This transfer is used in three places: + FloatOut (long-distance let-floating) + GHC.Core.Op.Simplify.Utils.abstractFloats (short-distance let-floating) + StgLiftLams (selectively lambda-lift local functions to top-level) + +Consider the short-distance let-floating: + + f = /\a. let g = rhs in ... + +Then if we float thus + + g' = /\a. rhs + f = /\a. ...[g' a/g].... + +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get + + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see #4345. + +It's not so simple to retain + * worker info + * rules +so we simply discard those. Sooner or later this may bite us. + +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g +-} + +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id + = modifyIdInfo transfer new_id + where + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info + new_arity = old_arity + arity_increase + new_occ_info = zapOccTailCallInfo old_occ_info + + old_strictness = strictnessInfo old_info + new_strictness = increaseStrictSigArity arity_increase old_strictness + old_cpr = cprInfo old_info + + transfer new_info = new_info `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` new_occ_info + `setStrictnessInfo` new_strictness + `setCprInfo` old_cpr + +isNeverLevPolyId :: Id -> Bool +isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Id/Info.hs @@ -0,0 +1,652 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Id.Info ( + -- * The IdDetails type + IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, + JoinArity, isJoinIdDetails_maybe, + RecSelParent(..), + + -- * The IdInfo type + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + + -- ** The OneShotInfo type + OneShotInfo(..), + oneShotInfo, noOneShotInfo, hasNoOneShotInfo, + setOneShotInfo, + + -- ** Zapping various forms of Info + zapLamInfo, zapFragileInfo, + zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + zapTailCallInfo, zapCallArityInfo, zapUnfolding, + + -- ** The ArityInfo type + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + callArityInfo, setCallArityInfo, + + -- ** Demand and strictness Info + strictnessInfo, setStrictnessInfo, + cprInfo, setCprInfo, + demandInfo, setDemandInfo, pprStrictness, + + -- ** Unfolding Info + unfoldingInfo, setUnfoldingInfo, + + -- ** The InlinePragInfo type + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- ** The OccInfo type + OccInfo(..), + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, + occInfo, setOccInfo, + + InsideLam(..), OneBranch(..), + + TailCallInfo(..), + tailCallInfo, isAlwaysTailCalled, + + -- ** The RuleInfo type + RuleInfo(..), + emptyRuleInfo, + isEmptyRuleInfo, ruleInfoFreeVars, + ruleInfoRules, setRuleInfoHead, + ruleInfo, setRuleInfo, + + -- ** The CAFInfo type + CafInfo(..), + ppCafInfo, mayHaveCafRefs, + cafInfo, setCafInfo, + + -- ** Tick-box Info + TickBoxOp(..), TickBoxId, + + -- ** Levity info + LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, + isNeverLevPolyIdInfo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core + +import GHC.Core.Class +import {-# SOURCE #-} PrimOp (PrimOp) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Types.ForeignCall +import Outputable +import GHC.Types.Module +import GHC.Types.Demand +import GHC.Types.Cpr +import Util + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setRuleInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setOneShotInfo`, + `setOccInfo`, + `setCafInfo`, + `setStrictnessInfo`, + `setCprInfo`, + `setDemandInfo`, + `setNeverLevPoly`, + `setLevityInfoWithType` + +{- +************************************************************************ +* * + IdDetails +* * +************************************************************************ +-} + +-- | Identifier Details +-- +-- The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId + + -- | The 'Id' for a record selector + | RecSelId + { sel_tycon :: RecSelParent + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + -- data T = forall a. MkT { x :: a } + } -- See Note [Naughty record selectors] in TcTyClsDecls + + | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ + | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ + + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + | ClassOpId Class -- ^ The 'Id' is a superclass selector, + -- or class operation of a class + + | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. + -- Type will be simple: no type families, newtypes, etc + + | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) + + | DFunId Bool -- ^ A dictionary function. + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + + | CoVarId -- ^ A coercion variable + -- This only covers /un-lifted/ coercions, of type + -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants + | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments + -- Note [Join points] in GHC.Core + +-- | Recursive Selector Parent +data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq + -- Either `TyCon` or `PatSyn` depending + -- on the origin of the record selector. + -- For a data type family, this is the + -- /instance/ 'TyCon' not the family 'TyCon' + +instance Outputable RecSelParent where + ppr p = case p of + RecSelData ty_con -> ppr ty_con + RecSelPatSyn ps -> ppr ps + +-- | Just a synonym for 'CoVarId'. Written separately so it can be +-- exported in the hs-boot file. +coVarDetails :: IdDetails +coVarDetails = CoVarId + +-- | Check if an 'IdDetails' says 'CoVarId'. +isCoVarDetails :: IdDetails -> Bool +isCoVarDetails CoVarId = True +isCoVarDetails _ = False + +isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity +isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity +isJoinIdDetails_maybe _ = Nothing + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (PrimOpId _) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ text "RecSel" <> + ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" + pp (JoinId arity) = text "JoinId" <> parens (int arity) + +{- +************************************************************************ +* * +\subsection{The main IdInfo type} +* * +************************************************************************ +-} + +-- | Identifier Information +-- +-- An 'IdInfo' gives /optional/ information about an 'Id'. If +-- present it never lies, but it may not be present, in which case there +-- is always a conservative assumption which can be made. +-- +-- Two 'Id's may have different info even though they have the same +-- 'Unique' (and are hence the same 'Id'); for example, one might lack +-- the properties attached to the other. +-- +-- Most of the 'IdInfo' gives information about the value, or definition, of +-- the 'Id', independent of its usage. Exceptions to this +-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. +-- +-- Performance note: when we update 'IdInfo', we have to reallocate this +-- entire record, so it is a good idea not to let this data structure get +-- too big. +data IdInfo + = IdInfo { + arityInfo :: !ArityInfo, + -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many + -- arguments this 'Id' has to be applied to before it doesn any + -- meaningful work. + ruleInfo :: RuleInfo, + -- ^ Specialisations of the 'Id's function which exist. + -- See Note [Specialisations and RULES in IdInfo] + unfoldingInfo :: Unfolding, + -- ^ The 'Id's unfolding + cafInfo :: CafInfo, + -- ^ 'Id' CAF info + oneShotInfo :: OneShotInfo, + -- ^ Info about a lambda-bound variable, if the 'Id' is one + inlinePragInfo :: InlinePragma, + -- ^ Any inline pragma attached to the 'Id' + occInfo :: OccInfo, + -- ^ How the 'Id' occurs in the program + strictnessInfo :: StrictSig, + -- ^ A strictness signature. Digests how a function uses its arguments + -- if applied to at least 'arityInfo' arguments. + cprInfo :: CprSig, + -- ^ Information on whether the function will ultimately return a + -- freshly allocated constructor. + demandInfo :: Demand, + -- ^ ID demand information + callArityInfo :: !ArityInfo, + -- ^ How this is called. This is the number of arguments to which a + -- binding can be eta-expanded without losing any sharing. + -- n <=> all calls have at least n arguments + levityInfo :: LevityInfo + -- ^ when applied, will this Id ever have a levity-polymorphic type? + } + +-- Setters + +setRuleInfo :: IdInfo -> RuleInfo -> IdInfo +setRuleInfo info sp = sp `seq` info { ruleInfo = sp } +setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo :: IdInfo -> OccInfo -> IdInfo +setOccInfo info oc = oc `seq` info { occInfo = oc } + -- Try to avoid space leaks by seq'ing + +setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfo info uf + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { unfoldingInfo = uf } + +setArityInfo :: IdInfo -> ArityInfo -> IdInfo +setArityInfo info ar = info { arityInfo = ar } +setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo +setCallArityInfo info ar = info { callArityInfo = ar } +setCafInfo :: IdInfo -> CafInfo -> IdInfo +setCafInfo info caf = info { cafInfo = caf } + +setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo +setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } + +setDemandInfo :: IdInfo -> Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } + +setCprInfo :: IdInfo -> CprSig -> IdInfo +setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } + +-- | Basic 'IdInfo' that carries no useful information whatsoever +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + cafInfo = vanillaCafInfo, + arityInfo = unknownArity, + ruleInfo = emptyRuleInfo, + unfoldingInfo = noUnfolding, + oneShotInfo = NoOneShotInfo, + inlinePragInfo = defaultInlinePragma, + occInfo = noOccInfo, + demandInfo = topDmd, + strictnessInfo = nopSig, + cprInfo = topCprSig, + callArityInfo = unknownArity, + levityInfo = NoLevityInfo + } + +-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references +noCafIdInfo :: IdInfo +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in GHC.Types.Id.Make. + +{- +************************************************************************ +* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +* * +************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) +-} + +-- | Arity Information +-- +-- An 'ArityInfo' of @n@ tells us that partial application of this +-- 'Id' to up to @n-1@ value arguments does essentially no work. +-- +-- That is not necessarily the same as saying that it has @n@ leading +-- lambdas, because coerces may get in the way. +-- +-- The arity might increase later in the compilation process, if +-- an extra lambda floats up to the binding site. +type ArityInfo = Arity + +-- | It is always safe to assume that an 'Id' has an arity of 0 +unknownArity :: Arity +unknownArity = 0 + +ppArityInfo :: Int -> SDoc +ppArityInfo 0 = empty +ppArityInfo n = hsep [text "Arity", int n] + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Inline Pragma Information +-- +-- Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragInfo = InlinePragma + +{- +************************************************************************ +* * + Strictness +* * +************************************************************************ +-} + +pprStrictness :: StrictSig -> SDoc +pprStrictness sig = ppr sig + +{- +************************************************************************ +* * + RuleInfo +* * +************************************************************************ + +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalId has an *empty* RuleInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +just for convenience really. + +However, LocalIds may have non-empty RuleInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. +-} + +-- | Rule Information +-- +-- Records the specializations of this 'Id' that we know about +-- in the form of rewrite 'CoreRule's that target them +data RuleInfo + = RuleInfo + [CoreRule] + DVarSet -- Locally-defined free vars of *both* LHS and RHS + -- of rules. I don't think it needs to include the + -- ru_fn though. + -- Note [Rule dependency info] in OccurAnal + +-- | Assume that no specializations exist: always safe +emptyRuleInfo :: RuleInfo +emptyRuleInfo = RuleInfo [] emptyDVarSet + +isEmptyRuleInfo :: RuleInfo -> Bool +isEmptyRuleInfo (RuleInfo rs _) = null rs + +-- | Retrieve the locally-defined free variables of both the left and +-- right hand sides of the specialization rules +ruleInfoFreeVars :: RuleInfo -> DVarSet +ruleInfoFreeVars (RuleInfo _ fvs) = fvs + +ruleInfoRules :: RuleInfo -> [CoreRule] +ruleInfoRules (RuleInfo rules _) = rules + +-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's +setRuleInfoHead :: Name -> RuleInfo -> RuleInfo +setRuleInfoHead fn (RuleInfo rules fvs) + = RuleInfo (map (setRuleIdName fn) rules) fvs + +{- +************************************************************************ +* * +\subsection[CG-IdInfo]{Code generator-related information} +* * +************************************************************************ +-} + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). + +-- | Constant applicative form Information +-- +-- Records whether an 'Id' makes Constant Applicative Form references +data CafInfo + = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: + -- + -- 1. A function or static constructor + -- that refers to one or more CAFs, or + -- + -- 2. A real live CAF + + | NoCafRefs -- ^ A function or static constructor + -- that refers to no CAFs. + deriving (Eq, Ord) + +-- | Assumes that the 'Id' has CAF references: definitely safe +vanillaCafInfo :: CafInfo +vanillaCafInfo = MayHaveCafRefs + +mayHaveCafRefs :: CafInfo -> Bool +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +instance Outputable CafInfo where + ppr = ppCafInfo + +ppCafInfo :: CafInfo -> SDoc +ppCafInfo NoCafRefs = text "NoCafRefs" +ppCafInfo MayHaveCafRefs = empty + +{- +************************************************************************ +* * +\subsection{Bulk operations on IdInfo} +* * +************************************************************************ +-} + +-- | This is used to remove information on lambda binders that we have +-- setup as part of a lambda group, assuming they will be applied all at once, +-- but turn out to be part of an unsaturated lambda as in e.g: +-- +-- > (\x1. \x2. e) arg1 +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, demandInfo = topDmd}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ occ | isAlwaysTailCalled occ = False + is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False + is_safe_occ _other = True + + safe_occ = case occ of + OneOcc{} -> occ { occ_in_lam = IsInsideLam + , occ_tail = NoTailCallInfo } + IAmALoopBreaker{} + -> occ { occ_tail = NoTailCallInfo } + _other -> occ + + is_safe_dmd dmd = not (isStrictDmd dmd) + +-- | Remove all demand info on the 'IdInfo' +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info = Just (info {demandInfo = topDmd}) + +-- | Remove usage (but not strictness) info on the 'IdInfo' +zapUsageInfo :: IdInfo -> Maybe IdInfo +zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) + +-- | Remove usage environment info from the strictness signature on the 'IdInfo' +zapUsageEnvInfo :: IdInfo -> Maybe IdInfo +zapUsageEnvInfo info + | hasDemandEnvSig (strictnessInfo info) + = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) + | otherwise + = Nothing + +zapUsedOnceInfo :: IdInfo -> Maybe IdInfo +zapUsedOnceInfo info + = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) + , demandInfo = zapUsedOnceDemand (demandInfo info) } + +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- ^ Zap info that depends on free variables +zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) + = new_unf `seq` -- The unfolding field is not (currently) strict, so we + -- force it here to avoid a (zapFragileUnfolding unf) thunk + -- which might leak space + Just (info `setRuleInfo` emptyRuleInfo + `setUnfoldingInfo` new_unf + `setOccInfo` zapFragileOcc occ) + where + new_unf = zapFragileUnfolding unf + +zapFragileUnfolding :: Unfolding -> Unfolding +zapFragileUnfolding unf + | isFragileUnfolding unf = noUnfolding + | otherwise = unf + +zapUnfolding :: Unfolding -> Unfolding +-- Squash all unfolding info, preserving only evaluated-ness +zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + +zapTailCallInfo :: IdInfo -> Maybe IdInfo +zapTailCallInfo info + = case occInfo info of + occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) + | otherwise -> Nothing + where + safe_occ = occ { occ_tail = NoTailCallInfo } + +zapCallArityInfo :: IdInfo -> IdInfo +zapCallArityInfo info = setCallArityInfo info 0 + +{- +************************************************************************ +* * +\subsection{TickBoxOp} +* * +************************************************************************ +-} + +type TickBoxId = Int + +-- | Tick box for Hpc-style coverage +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) + +{- +************************************************************************ +* * + Levity +* * +************************************************************************ + +Note [Levity info] +~~~~~~~~~~~~~~~~~~ + +Ids store whether or not they can be levity-polymorphic at any amount +of saturation. This is helpful in optimizing the levity-polymorphism check +done in the desugarer, where we can usually learn that something is not +levity-polymorphic without actually figuring out its type. See +isExprLevPoly in GHC.Core.Utils for where this info is used. Storing +this is required to prevent perf/compiler/T5631 from blowing up. + +-} + +-- See Note [Levity info] +data LevityInfo = NoLevityInfo -- always safe + | NeverLevityPolymorphic + deriving Eq + +instance Outputable LevityInfo where + ppr NoLevityInfo = text "NoLevityInfo" + ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" + +-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when +-- applied). The Type is only there for checking that it's really never levity +-- polymorphic +setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo +setNeverLevPoly info ty + = ASSERT2( not (resultIsLevPoly ty), ppr ty ) + info { levityInfo = NeverLevityPolymorphic } + +setLevityInfoWithType :: IdInfo -> Type -> IdInfo +setLevityInfoWithType info ty + | not (resultIsLevPoly ty) + = info { levityInfo = NeverLevityPolymorphic } + | otherwise + = info + +isNeverLevPolyIdInfo :: IdInfo -> Bool +isNeverLevPolyIdInfo info + | NeverLevityPolymorphic <- levityInfo info = True + | otherwise = False diff --git a/compiler/GHC/Types/Id/Info.hs-boot b/compiler/GHC/Types/Id/Info.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Id/Info.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.Id.Info where +import GhcPrelude +import Outputable +data IdInfo +data IdDetails + +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails +isCoVarDetails :: IdDetails -> Bool +pprIdDetails :: IdDetails -> SDoc + diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Id/Make.hs @@ -0,0 +1,1708 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + +- data constructors +- record selectors +- method and superclass selectors +- primitive operations +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Id.Make ( + mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + + mkPrimOpId, mkFCallId, + + unwrapNewTypeBody, wrapFamInstBody, + DataConBoxer(..), vanillaDataConBoxer, + mkDataConRep, mkDataConWorkId, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + realWorldPrimId, + voidPrimId, voidArgId, + nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, magicDictId, coerceId, + proxyHashId, noinlineId, noinlineIdName, + coerceName, + + -- Re-export error Ids + module GHC.Core.Op.ConstantFold + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Rules +import TysPrim +import TysWiredIn +import GHC.Core.Op.ConstantFold +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import TcType +import GHC.Core.Make +import GHC.Core.Utils ( mkCast, mkDefaultCase ) +import GHC.Core.Unfold +import GHC.Types.Literal +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Types.Name.Set +import GHC.Types.Name +import PrimOp +import GHC.Types.ForeignCall +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import PrelNames +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import Util +import GHC.Driver.Session +import Outputable +import FastString +import ListSetOps +import GHC.Types.Var (VarBndr(Bndr)) +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( maybeToList ) + +{- +************************************************************************ +* * +\subsection{Wired in Ids} +* * +************************************************************************ + +Note [Wired-in Ids] +~~~~~~~~~~~~~~~~~~~ +A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') +rather than by looking it up its name in some environment or fetching +it from an interface file. + +There are several reasons why an Id might appear in the wiredInIds: + +* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] + +* magicIds: see Note [magicIds] + +* errorIds, defined in GHC.Core.Make. + These error functions (e.g. rUNTIME_ERROR_ID) are wired in + because the desugarer generates code that mentions them directly + +In all cases except ghcPrimIds, there is a definition site in a +library module, which may be called (e.g. in higher order situations); +but the wired-in version means that the details are never read from +that module's interface file; instead, the full definition is right +here. + +Note [ghcPrimIds (aka pseudoops)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ghcPrimIds + + * Are exported from GHC.Prim + + * Can't be defined in Haskell, and hence no Haskell binding site, + but have perfectly reasonable unfoldings in Core + + * Either have a CompulsoryUnfolding (hence always inlined), or + of an EvaldUnfolding and void representation (e.g. void#) + + * Are (or should be) defined in primops.txt.pp as 'pseudoop' + Reason: that's how we generate documentation for them + +Note [magicIds] +~~~~~~~~~~~~~~~ +The magicIds + + * Are exported from GHC.Magic + + * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). + This definition at least generates Haddock documentation for them. + + * May or may not have a CompulsoryUnfolding. + + * But have some special behaviour that can't be done via an + unfolding from an interface file +-} + +wiredInIds :: [Id] +wiredInIds + = magicIds + ++ ghcPrimIds + ++ errorIds -- Defined in GHC.Core.Make + +magicIds :: [Id] -- See Note [magicIds] +magicIds = [lazyId, oneShotId, noinlineId] + +ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] +ghcPrimIds + = [ realWorldPrimId + , voidPrimId + , nullAddrId + , seqId + , magicDictId + , coerceId + , proxyHashId + ] + +{- +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + +Note [Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal +name of the form :R123Map, and we call it the representation tycon. +In contrast, Map is the family tycon (accessible via +tyConFamInst_maybe). A coercion allows you to move between +representation and family type. It is accessible from :R123Map via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +The wrapper and worker of MapPair get the types + + -- Wrapper + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) + + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +This coercion is conditionally applied by wrapFamInstBody. + +It's a bit more complicated if the data instance is a GADT as well! + + data instance T [a] where + T1 :: forall b. b -> T [Maybe b] + +Hence we translate to + + -- Wrapper + $WT1 :: forall b. b -> T [Maybe b] + $WT1 b v = T1 (Maybe b) b (Maybe b) v + `cast` sym (Co7T (Maybe b)) + + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + +Newtype instances through an additional wrinkle into the mix. Consider the +following example (adapted from #15318, comment:2): + + data family T a + newtype instance T [a] = MkT [a] + +Within the newtype instance, there are three distinct types at play: + +1. The newtype's underlying type, [a]. +2. The instance's representation type, TList a (where TList is the + representation tycon). +3. The family type, T [a]. + +We need two coercions in order to cast from (1) to (3): + +(a) A newtype coercion axiom: + + axiom coTList a :: TList a ~ [a] + + (Where TList is the representation tycon of the newtype instance.) + +(b) A data family instance coercion axiom: + + axiom coT a :: T [a] ~ TList a + +When we translate the newtype instance to Core, we obtain: + + -- Wrapper + $WMkT :: forall a. [a] -> T [a] + $WMkT a x = MkT a x |> Sym (coT a) + + -- Worker + MkT :: forall a. [a] -> TList [a] + MkT a x = x |> Sym (coTList a) + +Unlike for data instances, the worker for a newtype instance is actually an +executable function which expands to a cast, but otherwise, the general +strategy is essentially the same as for data instances. Also note that we have +a wrapper, which is unusual for a newtype, but we make GHC produce one anyway +for symmetry with the way data instances are handled. + +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should always be vanilla. At one +point this wasn't true, because the newtype arising from + class C a => D a +looked like + newtype T:D a = D:D (C a) +so the data constructor for T:C had a single argument, namely the +predicate (C a). But now we treat that as an ordinary argument, not +part of the theta-type, so all is well. + +Note [Newtype workers] +~~~~~~~~~~~~~~~~~~~~~~ +A newtype does not really have a worker. Instead, newtype constructors +just unfold into a cast. But we need *something* for, say, MkAge to refer +to. So, we do this: + +* The Id used as the newtype worker will have a compulsory unfolding to + a cast. See Note [Compulsory newtype unfolding] + +* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, + as those have special treatment in the back end. + +* There is no top-level binding, because the compulsory unfolding + means that it will be inlined (to a cast) at every call site. + +We probably should have a NewtypeWorkId, but these Ids disappear as soon as +we desugar anyway, so it seems a step too far. + +Note [Compulsory newtype unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype wrappers, just like workers, have compulsory unfoldings. +This is needed so that two optimizations involving newtypes have the same +effect whether a wrapper is present or not: + +(1) Case-of-known constructor. + See Note [beta-reduction in exprIsConApp_maybe]. + +(2) Matching against the map/coerce RULE. Suppose we have the RULE + + {-# RULE "map/coerce" map coerce = ... #-} + + As described in Note [Getting the map/coerce RULE to work], + the occurrence of 'coerce' is transformed into: + + {-# RULE "map/coerce" forall (c :: T1 ~R# T2). + map ((\v -> v) `cast` c) = ... #-} + + We'd like 'map Age' to match the LHS. For this to happen, Age + must be unfolded, otherwise we'll be stuck. This is tested in T16208. + +It also allows for the posssibility of levity polymorphic newtypes +with wrappers (with -XUnliftedNewtypes): + + newtype N (a :: TYPE r) = MkN a + +With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- +polymorphic. It's OK because MkN evaporates in the compiled code, becoming +just a cast. That is, it has a compulsory unfolding. As long as its +argument is not levity-polymorphic (which it can't be, according to +Note [Levity polymorphism invariants] in GHC.Core), and it's saturated, +no levity-polymorphic code ends up in the code generator. The saturation +condition is effectively checked by Note [Detecting forced eta expansion] +in GHC.HsToCore.Expr. + +However, if we make a *wrapper* for a newtype, we get into trouble. +The saturation condition is no longer checked (because hasNoBinding +returns False) and indeed we generate a forbidden levity-polymorphic +binding. + +The solution is simple, though: just make the newtype wrappers +as ephemeral as the newtype workers. In other words, give the wrappers +compulsory unfoldings and no bindings. The compulsory unfolding is given +in wrap_unf in mkDataConRep, and the lack of a binding happens in +GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no +implicit bindings. + +************************************************************************ +* * +\subsection{Dictionary selectors} +* * +************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +-} + +mkDictSelId :: Name -- Name of one of the *value* selectors + -- (dictionary superclass or method) + -> Class -> Id +mkDictSelId name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUserTyVarBinders data_con + n_ty_args = length tyvars + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + sel_ty = mkForAllTys tyvars $ + mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + getNth arg_tys val_index + + base_info = noCafIdInfo + `setArityInfo` 1 + `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig + `setLevityInfoWithType` sel_ty + + info | new_tycon + = base_info `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 + (mkDictSelRhs clas val_index) + -- See Note [Single-method classes] in TcInstDcls + -- for why alwaysInlinePragma + + | otherwise + = base_info `setRuleInfo` mkRuleInfo [rule] + -- Add a magic BuiltinRule, but no unfolding + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule val_index n_ty_args } + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + + strict_sig = mkClosedStrictSig [arg_dmd] topDiv + arg_dmd | new_tycon = evalDmd + | otherwise = mkManyUsedDmd $ + mkProdDmd [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where + tycon = classTyCon clas + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 arg_tys + + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) + (Var dict_id) + | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) + arg_ids (varToCoreExpr the_arg_id) + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } + +dictSelRule :: Int -> Arity -> RuleFun +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it +-- sel_i t1..tk (D t1..tk op1 ... opm) = opi +-- +dictSelRule val_index n_ty_args _ id_unf _ args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (wrapFloats floats $ getNth con_args val_index) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Data constructors +* * +************************************************************************ +-} + +mkDataConWorkId :: Name -> DataCon -> Id +mkDataConWorkId wkr_name data_con + | isNewTyCon tycon + = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info + -- See Note [Newtype workers] + + | otherwise + = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info + + where + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + + ----------- Workers for data types -------------- + alg_wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setStrictnessInfo` wkr_sig + `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + `setLevityInfoWithType` wkr_ty + -- NB: unboxed tuples have workers, so we can't use + -- setNeverLevPoly + + wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv + -- Note [Data-con worker strictness] + -- Notice that we do *not* say the worker Id is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has + -- case expressions that do the evals) but the *worker* MkT itself is + -- not. If we pretend it is strict then when we see + -- case x of y -> MkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- the worker MkT is strict) and drops the case. No, the workerId + -- MkT is not strict. + -- + -- However, the worker does have StrictnessMarks. When the simplifier + -- sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + ----------- Workers for newtypes -------------- + univ_tvs = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` newtype_unf + `setLevityInfoWithType` wkr_ty + id_arg1 = mkTemplateLocal 1 (head arg_tys) + res_ty_args = mkTyCoVarTys univ_tvs + newtype_unf = ASSERT2( isVanillaDataCon data_con && + isSingleton arg_tys + , ppr data_con ) + -- Note [Newtype datacons] + mkCompulsoryUnfolding $ + mkLams univ_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon res_ty_args (Var id_arg1) + +dataConCPR :: DataCon -> CprResult +dataConCPR con + | isDataTyCon tycon -- Real data types only; that is, + -- not unboxed tuples or newtypes + , null (dataConExTyCoVars con) -- No existentials + , wkr_arity > 0 + , wkr_arity <= mAX_CPR_SIZE + = conCpr (dataConTag con) + | otherwise + = topCpr + where + tycon = dataConTyCon con + wkr_arity = dataConRepArity con + + mAX_CPR_SIZE :: Arity + mAX_CPR_SIZE = 10 + -- We do not treat very big tuples as CPR-ish: + -- a) for a start we get into trouble because there aren't + -- "enough" unboxed tuple types (a tiresome restriction, + -- but hard to fix), + -- b) more importantly, big unboxed tuples get returned mainly + -- on the stack, and are often then allocated in the heap + -- by the caller. So doing CPR for them may in fact make + -- things worse. + +{- +------------------------------------------------- +-- Data constructor representation +-- +-- This is where we decide how to wrap/unwrap the +-- constructor fields +-- +-------------------------------------------------- +-} + +type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) + -- Unbox: bind rep vars by decomposing src var + +data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) + -- Box: build src arg using these rep vars + +-- | Data Constructor Boxer +newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) + -- Bind these src-level vars, returning the + -- rep-level vars to bind in the pattern + +vanillaDataConBoxer :: DataConBoxer +-- No transformation on arguments needed +vanillaDataConBoxer = DCB (\_tys args -> return (args, [])) + +{- +Note [Inline partially-applied constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We allow the wrapper to inline when partially applied to avoid +boxing values unnecessarily. For example, consider + + data Foo a = Foo !Int a + + instance Traversable Foo where + traverse f (Foo i a) = Foo i <$> f a + +This desugars to + + traverse f foo = case foo of + Foo i# a -> let i = I# i# + in map ($WFoo i) (f a) + +If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. +But if we inline the wrapper, we get + + map (\a. case i of I# i# a -> Foo i# a) (f a) + +and now case-of-known-constructor eliminates the redundant allocation. + +-} + +mkDataConRep :: DynFlags + -> FamInstEnvs + -> Name + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] + -> DataCon + -> UniqSM DataConRep +mkDataConRep dflags fam_envs wrap_name mb_bangs data_con + | not wrapper_reqd + = return NoDataConRep + + | otherwise + = do { wrap_args <- mapM newLocal wrap_arg_tys + ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + initial_wrap_app + + ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info + wrap_info = noCafIdInfo + `setArityInfo` wrap_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setInlinePragInfo` wrap_prag + `setUnfoldingInfo` wrap_unf + `setStrictnessInfo` wrap_sig + `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) + -- We need to get the CAF info right here because GHC.Iface.Tidy + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane + `setLevityInfoWithType` wrap_ty + + wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv + + wrap_arg_dmds = + replicate (length theta) topDmd ++ map mk_dmd arg_ibangs + -- Don't forget the dictionary arguments when building + -- the strictness signature (#14290). + + mk_dmd str | isBanged str = evalDmd + | otherwise = topDmd + + wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` + activeDuringFinal + -- See Note [Activation for data constructor wrappers] + + -- The wrapper will usually be inlined (see wrap_unf), so its + -- strictness and CPR info is usually irrelevant. But this is + -- not always the case; GHC may choose not to inline it. In + -- particular, the wrapper constructor is not inlined inside + -- an INLINE rhs or when it is not applied to any arguments. + -- See Note [Inline partially-applied constructor wrappers] + -- Passing Nothing here allows the wrapper to inline when + -- unsaturated. + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs + -- See Note [Compulsory newtype unfolding] + | otherwise = mkInlineUnfolding wrap_rhs + wrap_rhs = mkLams wrap_tvs $ + mkLams wrap_args $ + wrapFamInstBody tycon res_ty_args $ + wrap_body + + ; return (DCR { dcr_wrap_id = wrap_id + , dcr_boxer = mk_boxer boxers + , dcr_arg_tys = rep_tys + , dcr_stricts = rep_strs + -- For newtypes, dcr_bangs is always [HsLazy]. + -- See Note [HsImplBangs for newtypes]. + , dcr_bangs = arg_ibangs }) } + + where + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) + = dataConFullSig data_con + wrap_tvs = dataConUserTyVars data_con + res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs + + tycon = dataConTyCon data_con -- The representation TyCon (not family) + wrap_ty = dataConUserType data_con + ev_tys = eqSpecPreds eq_spec ++ theta + all_arg_tys = ev_tys ++ orig_arg_tys + ev_ibangs = map (const HsLazy) ev_tys + orig_bangs = dataConSrcBangs data_con + + wrap_arg_tys = theta ++ orig_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys + -- The wrap_args are the arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper + + new_tycon = isNewTyCon tycon + arg_ibangs + | new_tycon + = ASSERT( isSingleton orig_arg_tys ) + [HsLazy] -- See Note [HsImplBangs for newtypes] + | otherwise + = case mb_bangs of + Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) + orig_arg_tys orig_bangs + Just bangs -> bangs + + (rep_tys_w_strs, wrappers) + = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) + + (unboxers, boxers) = unzip wrappers + (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + + wrapper_reqd = + (not new_tycon + -- (Most) newtypes have only a worker, with the exception + -- of some newtypes written with GADT syntax. See below. + && (any isBanged (ev_ibangs ++ arg_ibangs) + -- Some forcing/unboxing (includes eq_spec) + || (not $ null eq_spec))) -- GADT + || isFamInstTyCon tycon -- Cast result + || dataConUserTyVarsArePermuted data_con + -- If the data type was written with GADT syntax and + -- orders the type variables differently from what the + -- worker expects, it needs a data con wrapper to reorder + -- the type variables. + -- See Note [Data con wrappers and GADT syntax]. + + initial_wrap_app = Var (dataConWorkId data_con) + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec + + mk_boxer :: [Boxer] -> DataConBoxer + mk_boxer boxers = DCB (\ ty_args src_vars -> + do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars + subst1 = zipTvSubst univ_tvs ty_args + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyCoVarTys ex_vars) + ; (rep_ids, binds) <- go subst2 boxers term_vars + ; return (ex_vars ++ rep_ids, binds) } ) + + go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) + go subst (UnitBox : boxers) (src_var : src_vars) + = do { (rep_ids2, binds) <- go subst boxers src_vars + ; return (src_var : rep_ids2, binds) } + go subst (Boxer boxer : boxers) (src_var : src_vars) + = do { (rep_ids1, arg) <- boxer subst + ; (rep_ids2, binds) <- go subst boxers src_vars + ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } + go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) + + mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr + mk_rep_app [] con_app + = return con_app + mk_rep_app ((wrap_arg, unboxer) : prs) con_app + = do { (rep_ids, unbox_fn) <- unboxer wrap_arg + ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) + ; return (unbox_fn expr) } + +{- Note [Activation for data constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Activation on a data constructor wrapper allows it to inline only in Phase +0. This way rules have a chance to fire if they mention a data constructor on +the left + RULE "foo" f (K a b) = ... +Since the LHS of rules are simplified with InitialPhase, we won't +inline the wrapper on the LHS either. + +On the other hand, this means that exprIsConApp_maybe must be able to deal +with wrappers so that case-of-constructor is not delayed; see +Note [exprIsConApp_maybe on data constructors with wrappers] for details. + +It used to activate in phases 2 (afterInitial) and later, but it makes it +awkward to write a RULE[1] with a constructor on the left: it would work if a +constructor has no wrapper, but whether a constructor has a wrapper depends, for +instance, on the order of type argument of that constructors. Therefore changing +the order of type argument could make previously working RULEs fail. + +See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . + + +Note [Bangs on imported data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs +from imported modules. + +- Nothing <=> use HsSrcBangs +- Just bangs <=> use HsImplBangs + +For imported types we can't work it all out from the HsSrcBangs, +because we want to be very sure to follow what the original module +(where the data type was declared) decided, and that depends on what +flags were enabled when it was compiled. So we record the decisions in +the interface file. + +The HsImplBangs passed are in 1-1 correspondence with the +dataConOrigArgTys of the DataCon. + +Note [Data con wrappers and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int# + +We certainly do not want to make a wrapper + $WMkT x = case x of y { DEFAULT -> MkT y } + +For a start, it's still to generate a no-op. But worse, since wrappers +are currently injected at TidyCore, we don't even optimise it away! +So the stupid case expression stays there. This actually happened for +the Integer data type (see #1600 comment:66)! + +Note [Data con wrappers and GADT syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two very similar data types: + + data T1 a b = MkT1 b + + data T2 a b where + MkT2 :: forall b a. b -> T2 a b + +Despite their similar appearance, T2 will have a data con wrapper but T1 will +not. What sets them apart? The types of their constructors, which are: + + MkT1 :: forall a b. b -> T1 a b + MkT2 :: forall b a. b -> T2 a b + +MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` +would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon +for further discussion on this topic. + +The worker data cons for T1 and T2, however, both have types such that `a` is +expected to come before `b` as arguments. Because MkT2 permutes this order, it +needs a data con wrapper to swizzle around the type variables to be in the +order the worker expects. + +A somewhat surprising consequence of this is that *newtypes* can have data con +wrappers! After all, a newtype can also be written with GADT syntax: + + newtype T3 a b where + MkT3 :: forall b a. b -> T3 a b + +Again, this needs a wrapper data con to reorder the type variables. It does +mean that this newtype constructor requires another level of indirection when +being called, but the inliner should make swift work of that. + +Note [HsImplBangs for newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the time, we use the dataConSrctoImplBang function to decide what +strictness/unpackedness to use for the fields of a data type constructor. But +there is an exception to this rule: newtype constructors. You might not think +that newtypes would pose a challenge, since newtypes are seemingly forbidden +from having strictness annotations in the first place. But consider this +(from #16141): + + {-# LANGUAGE StrictData #-} + {-# OPTIONS_GHC -O #-} + newtype T a b where + MkT :: forall b a. Int -> T a b + +Because StrictData (plus optimization) is enabled, invoking +dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! +This would be disastrous, since the wrapper for `MkT` uses a coercion involving +Int, not Int#. + +Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the +case of a newtype constructor, we simply hardcode its dcr_bangs field to +[HsLazy]. +-} + +------------------------- +newLocal :: Type -> UniqSM Var +newLocal ty = do { uniq <- getUniqueM + ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } + -- We should not have "OrCoVar" here, this is a bug (#17545) + + +-- | Unpack/Strictness decisions from source module. +-- +-- This function should only ever be invoked for data constructor fields, and +-- never on the field of a newtype constructor. +-- See @Note [HsImplBangs for newtypes]@. +dataConSrcToImplBang + :: DynFlags + -> FamInstEnvs + -> Type + -> HsSrcBang + -> HsImplBang + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk NoSrcStrict) + | xopt LangExt.StrictData dflags -- StrictData => strict field + = dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk SrcStrict) + | otherwise -- no StrictData => lazy field + = HsLazy + +dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) + = HsLazy + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang _ unpk_prag SrcStrict) + | isUnliftedType arg_ty + = HsLazy -- For !Int#, say, use HsLazy + -- See Note [Data con wrappers and unlifted types] + + | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas + -- Don't unpack if we aren't optimising; rather arbitrarily, + -- we use -fomit-iface-pragmas as the indication + , let mb_co = topNormaliseType_maybe fam_envs arg_ty + -- Unwrap type families and newtypes + arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } + , isUnpackableType dflags fam_envs arg_ty' + , (rep_tys, _) <- dataConArgUnpack arg_ty' + , case unpk_prag of + NoSrcUnpack -> + gopt Opt_UnboxStrictFields dflags + || (gopt Opt_UnboxSmallStrictFields dflags + && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + srcUnpack -> isSrcUnpacked srcUnpack + = case mb_co of + Nothing -> HsUnpack Nothing + Just (co,_) -> HsUnpack (Just co) + + | otherwise -- Record the strict-but-no-unpack decision + = HsStrict + + +-- | Wrappers/Workers and representation following Unpack/Strictness +-- decisions +dataConArgRep + :: Type + -> HsImplBang + -> ([(Type,StrictnessMark)] -- Rep types + ,(Unboxer,Boxer)) + +dataConArgRep arg_ty HsLazy + = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep arg_ty HsStrict + = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + +dataConArgRep arg_ty (HsUnpack Nothing) + | (rep_tys, wrappers) <- dataConArgUnpack arg_ty + = (rep_tys, wrappers) + +dataConArgRep _ (HsUnpack (Just co)) + | let co_rep_ty = coercionRKind co + , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty + = (rep_tys, wrapCo co co_rep_ty wrappers) + + +------------------------- +wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) +wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty + = (unboxer, boxer) + where + unboxer arg_id = do { rep_id <- newLocal rep_ty + ; (rep_ids, rep_fn) <- unbox_rep rep_id + ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) + ; return (rep_ids, Let co_bind . rep_fn) } + boxer = Boxer $ \ subst -> + do { (rep_ids, rep_expr) + <- case box_rep of + UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) + ; return ([rep_id], Var rep_id) } + Boxer boxer -> boxer subst + ; let sco = substCoUnchecked subst co + ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } + +------------------------ +seqUnboxer :: Unboxer +seqUnboxer v = return ([v], mkDefaultCase (Var v) v) + +unitUnboxer :: Unboxer +unitUnboxer v = return ([v], \e -> e) + +unitBoxer :: Boxer +unitBoxer = UnitBox + +------------------------- +dataConArgUnpack + :: Type + -> ( [(Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) + +dataConArgUnpack arg_ty + | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty + , Just con <- tyConSingleAlgDataCon_maybe tc + -- NB: check for an *algebraic* data type + -- A recursive newtype might mean that + -- 'arg_ty' is a newtype + , let rep_tys = dataConInstArgTys con tc_args + = ASSERT( null (dataConExTyCoVars con) ) + -- Note [Unpacking GADTs and existentials] + ( rep_tys `zip` dataConRepStrictness con + ,( \ arg_id -> + do { rep_ids <- mapM newLocal rep_tys + ; let unbox_fn body + = mkSingleAltCase (Var arg_id) arg_id + (DataAlt con) rep_ids body + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + | otherwise + = pprPanic "dataConArgUnpack" (ppr arg_ty) + -- An interface file specified Unpacked, but we couldn't unpack it + +isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool +-- True if we can unpack the UNPACK the argument type +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! +isUnpackableType dflags fam_envs ty + | Just data_con <- unpackable_type ty + = ok_con_args emptyNameSet data_con + | otherwise + = False + where + ok_con_args dcs con + | dc_name `elemNameSet` dcs + = False + | otherwise + = all (ok_arg dcs') + (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + where + dc_name = getName con + dcs' = dcs `extendNameSet` dc_name + + ok_arg dcs (ty, bang) + = not (attempt_unpack bang) || ok_ty dcs norm_ty + where + norm_ty = topNormaliseType fam_envs ty + + ok_ty dcs ty + | Just data_con <- unpackable_type ty + = ok_con_args dcs data_con + | otherwise + = True -- NB True here, in contrast to False at top level + + attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags + attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) + = True + attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) + = True -- Be conservative + attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags -- Be conservative + attempt_unpack _ = False + + unpackable_type :: Type -> Maybe DataCon + -- Works just on a single level + unpackable_type ty + | Just (tc, _) <- splitTyConApp_maybe ty + , Just data_con <- tyConSingleAlgDataCon_maybe tc + , null (dataConExTyCoVars data_con) + -- See Note [Unpacking GADTs and existentials] + = Just data_con + | otherwise + = Nothing + +{- +Note [Unpacking GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is nothing stopping us unpacking a data type with equality +components, like + data Equal a b where + Equal :: Equal a a + +And it'd be fine to unpack a product type with existential components +too, but that would require a bit more plumbing, so currently we don't. + +So for now we require: null (dataConExTyCoVars data_con) +See #14978 + +Note [Unpack one-wide fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag UnboxSmallStrictFields ensures that any field that can +(safely) be unboxed to a word-sized unboxed field, should be so unboxed. +For example: + + data A = A Int# + newtype B = B A + data C = C !B + data D = D !C + data E = E !() + data F = F !D + data G = G !F !F + +All of these should have an Int# as their representation, except +G which should have two Int#s. + +However + + data T = T !(S Int) + data S = S !a + +Here we can represent T with an Int#. + +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data R = MkR {-# UNPACK #-} !S Int + data S = MkS {-# UNPACK #-} !Int +The representation arguments of MkR are the *representation* arguments +of S (plus Int); the rep args of MkS are Int#. This is all fine. + +But be careful not to try to unbox this! + data T = MkT {-# UNPACK #-} !T Int +Because then we'd get an infinite number of arguments. + +Here is a more complicated case: + data S = MkS {-# UNPACK #-} !T Int + data T = MkT {-# UNPACK #-} !S Int +Each of S and T must decide independently whether to unpack +and they had better not both say yes. So they must both say no. + +Also behave conservatively when there is no UNPACK pragma + data T = MkS !T Int +with -funbox-strict-fields or -funbox-small-strict-fields +we need to behave as if there was an UNPACK pragma there. + +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + +************************************************************************ +* * + Wrapping and unwrapping newtypes and type families +* * +************************************************************************ +-} + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon associated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- If a coercion constructor is provided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops + +wrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkSymCo co) + where + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] + +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a splitting operation (cf, TcPat.tcConPat). + +unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- See Note [Wrappers for data instance tycons] +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args body + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) + | otherwise + = body + +{- +************************************************************************ +* * +\subsection{Primitive operations} +* * +************************************************************************ +-} + +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op) name ty info + + -- PrimOps don't ever construct a product, but we want to preserve bottoms + cpr + | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr + | otherwise = topCpr + + info = noCafIdInfo + `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig arity cpr + `setInlinePragInfo` neverInlinePragma + `setLevityInfoWithType` res_ty + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf #7287 + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id +mkFCallId dflags uniq fcall ty + = ASSERT( noFreeVarsOfType ty ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq occ_str + + info = noCafIdInfo + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig + `setLevityInfoWithType` ty + + (bndrs, _) = tcSplitPiTys ty + arity = count isAnonTyCoBinder bndrs + strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv + -- the call does not claim to be strict in its arguments, since they + -- may be lifted (foreign import prim) and the called code doesn't + -- necessarily force them. See #11076. +{- +************************************************************************ +* * +\subsection{DictFuns and default methods} +* * +************************************************************************ + +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +NB: See also Note [Exported LocalIds] in GHC.Types.Id +-} + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id +-- Implements the DFun Superclass Invariant (see TcInstDcls) +-- See Note [Dict funs and default methods] + +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalId (DFunId is_nt) + dfun_name + dfun_ty + where + is_nt = isNewTyCon (classTyCon clas) + dfun_ty = mkDictFunTy tvs theta clas tys + +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type +mkDictFunTy tvs theta clas tys + = mkSpecSigmaTy tvs theta (mkClassPred clas tys) + +{- +************************************************************************ +* * +\subsection{Un-definable} +* * +************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. If we had a way to get a compulsory unfolding from an interface +file, we could do that, but we don't right now. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. +-} + +nullAddrName, seqName, + realWorldName, voidPrimIdName, coercionTokenName, + magicDictName, coerceName, proxyName :: Name +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId + +lazyIdName, oneShotName, noinlineIdName :: Name +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId + +------------------------------------------------ +proxyHashId :: Id +proxyHashId + = pcMiscPrelId proxyName ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` ty ) + where + -- proxy# :: forall {k} (a:k). Proxy# k a + -- + -- The visibility of the `k` binder is Inferred to match the type of the + -- Proxy data constructor (#16293). + [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id + kv_ty = mkTyVarTy kv + tv_ty = mkTyVarTy tv + ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty + +------------------------------------------------ +nullAddrId :: Id +-- nullAddr# :: Addr# +-- The reason it is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + `setNeverLevPoly` addrPrimTy + +------------------------------------------------ +seqId :: Id -- See Note [seqId magic] +seqId = pcMiscPrelId seqName ty info + where + info = noCafIdInfo `setInlinePragInfo` inline_prag + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + inline_prag + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter + NoSourceText 0 + -- Make 'seq' not inline-always, so that simpleOptExpr + -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the + -- LHS of rules. That way we can have rules for 'seq'; + -- see Note [seqId magic] + + -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b + ty = + mkInvForAllTy runtimeRep2TyVar + $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] + $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) + + [x,y] = mkTemplateLocals [alphaTy, openBetaTy] + rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ + Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] + +------------------------------------------------ +lazyId :: Id -- See Note [lazyId magic] +lazyId = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + +noinlineId :: Id -- See Note [noinlineId magic] +noinlineId = pcMiscPrelId noinlineIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + +oneShotId :: Id -- See Note [The oneShot function] +oneShotId = pcMiscPrelId oneShotName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] + (mkVisFunTy fun_ty fun_ty) + fun_ty = mkVisFunTy openAlphaTy openBetaTy + [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] + x' = setOneShotLambda x -- Here is the magic bit! + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , body, x'] $ + Var body `App` Var x + +-------------------------------------------------------------------------------- +magicDictId :: Id -- See Note [magicDictId magic] +magicDictId = pcMiscPrelId magicDictName ty info + where + info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] alphaTy + +-------------------------------------------------------------------------------- + +coerceId :: Id +coerceId = pcMiscPrelId coerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] + ty = mkForAllTys [ Bndr rv Inferred + , Bndr av Specified + , Bndr bv Specified + ] $ + mkInvisFunTy eqRTy $ + mkVisFunTy a b + + bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy + (\r -> [tYPE r, tYPE r]) + + [r, a, b] = mkTyVarTys bndrs + + [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] + rhs = mkLams (bndrs ++ [eqR, x]) $ + mkWildCase (Var eqR) eqRTy b $ + [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] + +{- +Note [seqId magic] +~~~~~~~~~~~~~~~~~~ +'GHC.Prim.seq' is special in several ways. + +a) Its fixity is set in GHC.Iface.Load.ghcPrimIface + +b) It has quite a bit of desugaring magic. + See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3) + +c) There is some special rule handing: Note [User-defined RULES for seq] + +Historical note: + In TcExpr we used to need a special typing rule for 'seq', to handle calls + whose second argument had an unboxed type, e.g. x `seq` 3# + + However, with levity polymorphism we can now give seq the type seq :: + forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this + case without special treatment in the typechecker. + +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Roman found situations where he had + case (f n) of _ -> e +where he knew that f (which was strict in n) would terminate if n did. +Notice that the result of (f n) is discarded. So it makes sense to +transform to + case n of _ -> e + +Rather than attempt some general analysis to support this, I've added +enough support that you can do this using a rewrite rule: + + RULE "f/seq" forall n. seq (f n) = seq n + +You write that rule. When GHC sees a case expression that discards +its result, it mentally transforms it to a call to 'seq' and looks for +a RULE. (This is done in GHC.Core.Op.Simplify.trySeqRules.) As usual, the +correctness of the rule is up to you. + +VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. +If we wrote + RULE "f/seq" forall n e. seq (f n) e = seq n e +with rule arity 2, then two bad things would happen: + + - The magical desugaring done in Note [seqId magic] item (b) + for saturated application of 'seq' would turn the LHS into + a case expression! + + - The code in GHC.Core.Op.Simplify.rebuildCase would need to actually supply + the value argument, which turns out to be awkward. + +See also: Note [User-defined RULES for seq] in GHC.Core.Op.Simplify. + + +Note [lazyId magic] +~~~~~~~~~~~~~~~~~~~ +lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) + +'lazy' is used to make sure that a sub-expression, and its free variables, +are truly used call-by-need, with no code motion. Key examples: + +* pseq: pseq a b = a `seq` lazy b + We want to make sure that the free vars of 'b' are not evaluated + before 'a', even though the expression is plainly strict in 'b'. + +* catch: catch a b = catch# (lazy a) b + Again, it's clear that 'a' will be evaluated strictly (and indeed + applied to a state token) but we want to make sure that any exceptions + arising from the evaluation of 'a' are caught by the catch (see + #11555). + +Implementing 'lazy' is a bit tricky: + +* It must not have a strictness signature: by being a built-in Id, + all the info about lazyId comes from here, not from GHC.Base.hi. + This is important, because the strictness analyser will spot it as + strict! + +* It must not have an unfolding: it gets "inlined" by a HACK in + CorePrep. It's very important to do this inlining *after* unfoldings + are exposed in the interface file. Otherwise, the unfolding for + (say) pseq in the interface file will not mention 'lazy', so if we + inline 'pseq' we'll totally miss the very thing that 'lazy' was + there for in the first place. See #3259 for a real world + example. + +* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must + avoid using call by value here: + case e of r -> catch# r b + Avoiding that is the whole point of 'lazy'. So in CorePrep (which + generate the 'case' expression for a call-by-value call) we must + spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' + instead. + +* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it + appears un-applied, we'll end up just calling it. + +Note [noinlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~ +noinline :: forall a. a -> a + +'noinline' is used to make sure that a function f is never inlined, +e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE +could be used to achieve this effect; however, this has the unfortunate +result of leaving a (useless) call to noinline at runtime. So we have +a little bit of magic to optimize away 'noinline' after we are done +running the simplifier. + +'noinline' needs to be wired-in because it gets inserted automatically +when we serialize an expression to the interface format. See +Note [Inlining and hs-boot files] in GHC.CoreToIface + +Note that noinline as currently implemented can hide some simplifications since +it hides strictness from the demand analyser. Specifically, the demand analyser +will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' +specifies that it is strict in its argument. We considered fixing this this by adding a +special case to the demand analyser to address #16588. However, the special +case seemed like a large and expensive hammer to address a rare case and +consequently we rather opted to use a more minimal solution. + +Note [The oneShot function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the context of making left-folds fuse somewhat okish (see ticket #7994 +and Note [Left folds via right fold]) it was determined that it would be useful +if library authors could explicitly tell the compiler that a certain lambda is +called at most once. The oneShot function allows that. + +'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted +types as well (#10744); e.g. + oneShot (\x:Int# -> x +# 1#) + +Like most magic functions it has a compulsory unfolding, so there is no need +for a real definition somewhere. We have one in GHC.Magic for the convenience +of putting the documentation there. + +It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: + +A typical call looks like + oneShot (\y. e) +after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get + (\f \x[oneshot]. f x) (\y. e) + --> \x[oneshot]. ((\y.e) x) + --> \x[oneshot] e[x/y] +which is what we want. + +It is only effective if the one-shot info survives as long as possible; in +particular it must make it into the interface in unfoldings. See Note [Preserve +OneShotInfo] in GHC.Core.Op.Tidy. + +Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. + + +Note [magicDictId magic] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The identifier `magicDict` is just a place-holder, which is used to +implement a primitive that we cannot define in Haskell but we can write +in Core. It is declared with a place-holder type: + + magicDict :: forall a. a + +The intention is that the identifier will be used in a very specific way, +to create dictionaries for classes with a single method. Consider a class +like this: + + class C a where + f :: T a + +We are going to use `magicDict`, in conjunction with a built-in Prelude +rule, to cast values of type `T a` into dictionaries for `C a`. To do +this, we define a function like this in the library: + + data WrapC a b = WrapC (C a => Proxy a -> b) + + withT :: (C a => Proxy a -> b) + -> T a -> Proxy a -> b + withT f x y = magicDict (WrapC f) x y + +The purpose of `WrapC` is to avoid having `f` instantiated. +Also, it avoids impredicativity, because `magicDict`'s type +cannot be instantiated with a forall. The field of `WrapC` contains +a `Proxy` parameter which is used to link the type of the constraint, +`C a`, with the type of the `Wrap` value being made. + +Next, we add a built-in Prelude rule (see GHC.Core.Op.ConstantFold), +which will replace the RHS of this definition with the appropriate +definition in Core. The rewrite rule works as follows: + + magicDict @t (wrap @a @b f) x y +----> + f (x `cast` co a) y + +The `co` coercion is the newtype-coercion extracted from the type-class. +The type class is obtain by looking at the type of wrap. + + +------------------------------------------------------------- +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: Void# -> (# p, q #) + +This comes up in strictness analysis + +Note [evaldUnfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The evaldUnfolding makes it look that some primitive value is +evaluated, which in turn makes Simplify.interestingArg return True, +which in turn makes INLINE things applied to said value likely to be +inlined. +-} + +realWorldPrimId :: Id -- :: State# RealWorld +realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setOneShotInfo` stateHackOneShot + `setNeverLevPoly` realWorldStatePrimTy) + +voidPrimId :: Id -- Global constant :: Void# +voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` voidPrimTy) + +voidArgId :: Id -- Local lambda-bound :: Void# +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) + noCafIdInfo + +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobalWithInfo name ty info + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. diff --git a/compiler/GHC/Types/Id/Make.hs-boot b/compiler/GHC/Types/Id/Make.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Id/Make.hs-boot @@ -0,0 +1,15 @@ +module GHC.Types.Id.Make where +import GHC.Types.Name( Name ) +import GHC.Types.Var( Id ) +import GHC.Core.Class( Class ) +import {-# SOURCE #-} GHC.Core.DataCon( DataCon ) +import {-# SOURCE #-} PrimOp( PrimOp ) + +data DataConBoxer + +mkDataConWorkId :: Name -> DataCon -> Id +mkDictSelId :: Name -> Class -> Id + +mkPrimOpId :: PrimOp -> Id + +magicDictId :: Id diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Literal.hs @@ -0,0 +1,847 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[Literal]{@Literal@: literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Literal + ( + -- * Main data type + Literal(..) -- Exported to ParseIface + , LitNumType(..) + + -- ** Creating Literals + , mkLitInt, mkLitIntWrap, mkLitIntWrapC + , mkLitWord, mkLitWordWrap, mkLitWordWrapC + , mkLitInt64, mkLitInt64Wrap + , mkLitWord64, mkLitWord64Wrap + , mkLitFloat, mkLitDouble + , mkLitChar, mkLitString + , mkLitInteger, mkLitNatural + , mkLitNumber, mkLitNumberWrap + + -- ** Operations on Literals + , literalType + , absentLiteralOf + , pprLiteral + , litNumIsSigned + , litNumCheckRange + + -- ** Predicates on Literals and their contents + , litIsDupable, litIsTrivial, litIsLifted + , inCharRange + , isZeroLit + , litFitsInChar + , litValue, isLitValue, isLitValue_maybe, mapLitValue + + -- ** Coercions + , word2IntLit, int2WordLit + , narrowLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TysPrim +import PrelNames +import GHC.Core.Type +import GHC.Core.TyCon +import Outputable +import FastString +import GHC.Types.Basic +import Binary +import Constants +import GHC.Platform +import GHC.Types.Unique.FM +import Util + +import Data.ByteString (ByteString) +import Data.Int +import Data.Word +import Data.Char +import Data.Maybe ( isJust ) +import Data.Data ( Data ) +import Data.Proxy +import Numeric ( fromRat ) + +{- +************************************************************************ +* * +\subsection{Literals} +* * +************************************************************************ +-} + +-- | So-called 'Literal's are one of: +-- +-- * An unboxed numeric literal or floating-point literal which is presumed +-- to be surrounded by appropriate constructors (@Int#@, etc.), so that +-- the overall thing makes sense. +-- +-- We maintain the invariant that the 'Integer' in the 'LitNumber' +-- constructor is actually in the (possibly target-dependent) range. +-- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying +-- the target machine's wrapping semantics. Use these in situations +-- where you know the wrapping semantics are correct. +-- +-- * The literal derived from the label mentioned in a \"foreign label\" +-- declaration ('LitLabel') +-- +-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' +-- (i.e. 'MutVar#') when the the value is never used. +-- +-- * A character +-- * A string +-- * The NULL pointer +-- +data Literal + = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with + -- 'mkLitChar' + + | LitNumber !LitNumType !Integer Type + -- ^ Any numeric literal that can be + -- internally represented with an Integer. + -- See Note [Types of LitNumbers] below for the + -- Type field. + + | LitString ByteString -- ^ A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a @\'\\0\'@ + -- terminator. Create with 'mkLitString' + + | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value + -- that can be represented as a Literal. Create + -- with 'nullAddrLit' + + | LitRubbish -- ^ A nonsense value, used when an unlifted + -- binding is absent and has type + -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. + -- May be lowered by code-gen to any possible + -- value. Also see Note [Rubbish literals] + + | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' + | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' + + | LitLabel FastString (Maybe Int) FunctionOrData + -- ^ A label literal. Parameters: + -- + -- 1) The name of the symbol mentioned in the + -- declaration + -- + -- 2) The size (in bytes) of the arguments + -- the label expects. Only applicable with + -- @stdcall@ labels. @Just x@ => @\@ will + -- be appended to label name when emitting + -- assembly. + -- + -- 3) Flag indicating whether the symbol + -- references a function or a data + deriving Data + +-- | Numeric literal type +data LitNumType + = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) + | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) + | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits + | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits + deriving (Data,Enum,Eq,Ord) + +-- | Indicate if a numeric literal type supports negative numbers +litNumIsSigned :: LitNumType -> Bool +litNumIsSigned nt = case nt of + LitNumInteger -> True + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> False + LitNumWord64 -> False + +{- +Note [Integer literals] +~~~~~~~~~~~~~~~~~~~~~~~ +An Integer literal is represented using, well, an Integer, to make it +easier to write RULEs for them. They also contain the Integer type, so +that e.g. literalType can return the right Type for them. + +They only get converted into real Core, + mkInteger [c1, c2, .., cn] +during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the +core will be, so that it can see whether it involves CAFs. + +When we initially build an Integer literal, notably when +deserialising it from an interface file (see the Binary instance +below), we don't have convenient access to the mkInteger Id. So we +just use an error thunk, and fill in the real Id when we do tcIfaceLit +in GHC.IfaceToCore. + +Note [Natural literals] +~~~~~~~~~~~~~~~~~~~~~~~ +Similar to Integer literals. + +Note [String literals] +~~~~~~~~~~~~~~~~~~~~~~ + +String literals are UTF-8 encoded and stored into ByteStrings in the following +ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals +with the BytesPrimL constructor (see #14741). + +It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite +bad for performance with large strings (see #16198 and #14741). + +To include string literals into output objects, the assembler code generator has +to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] +for more details. + +-} + +instance Binary LitNumType where + put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) + get bh = do + h <- getByte bh + return (toEnum (fromIntegral h)) + +instance Binary Literal where + put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa + put_ bh (LitString ab) = do putByte bh 1; put_ bh ab + put_ bh (LitNullAddr) = do putByte bh 2 + put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai + put_ bh (LitLabel aj mb fod) + = do putByte bh 5 + put_ bh aj + put_ bh mb + put_ bh fod + put_ bh (LitNumber nt i _) + = do putByte bh 6 + put_ bh nt + put_ bh i + put_ bh (LitRubbish) = do putByte bh 7 + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (LitChar aa) + 1 -> do + ab <- get bh + return (LitString ab) + 2 -> do + return (LitNullAddr) + 3 -> do + ah <- get bh + return (LitFloat ah) + 4 -> do + ai <- get bh + return (LitDouble ai) + 5 -> do + aj <- get bh + mb <- get bh + fod <- get bh + return (LitLabel aj mb fod) + 6 -> do + nt <- get bh + i <- get bh + -- Note [Types of LitNumbers] + let t = case nt of + LitNumInt -> intPrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord64 -> word64PrimTy + -- See Note [Integer literals] + LitNumInteger -> + panic "Evaluated the place holder for mkInteger" + -- and Note [Natural literals] + LitNumNatural -> + panic "Evaluated the place holder for mkNatural" + return (LitNumber nt i t) + _ -> do + return (LitRubbish) + +instance Outputable Literal where + ppr = pprLiteral id + +instance Eq Literal where + a == b = compare a b == EQ + +-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in +-- 'TrieMap.CoreMap'. +instance Ord Literal where + compare = cmpLit + +{- + Construction + ~~~~~~~~~~~~ +-} + +{- Note [Word/Int underflow/overflow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and +unsigned integral types): "All arithmetic is performed modulo 2^n, where n is +the number of bits in the type." + +GHC stores Word# and Int# constant values as Integer. Core optimizations such +as constant folding must ensure that the Integer value remains in the valid +target Word/Int range (see #13172). The following functions are used to +ensure this. + +Note that we *don't* warn the user about overflow. It's not done at runtime +either, and compilation of completely harmless things like + ((124076834 :: Word32) + (2147483647 :: Word32)) +doesn't yield a warning. Instead we simply squash the value into the *target* +Int/Word range. +-} + +-- | Wrap a literal number according to its type +wrapLitNumber :: Platform -> Literal -> Literal +wrapLitNumber platform v@(LitNumber nt i t) = case nt of + LitNumInt -> case platformWordSize platform of + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + LitNumWord -> case platformWordSize platform of + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + LitNumInteger -> v + LitNumNatural -> v +wrapLitNumber _ x = x + +-- | Create a numeric 'Literal' of the given type +mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Type -> Literal +mkLitNumberWrap platform nt i t = wrapLitNumber platform (LitNumber nt i t) + +-- | Check that a given number is in the range of a numeric literal +litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool +litNumCheckRange platform nt i = case nt of + LitNumInt -> platformInIntRange platform i + LitNumWord -> platformInWordRange platform i + LitNumInt64 -> inInt64Range i + LitNumWord64 -> inWord64Range i + LitNumNatural -> i >= 0 + LitNumInteger -> True + +-- | Create a numeric 'Literal' of the given type +mkLitNumber :: Platform -> LitNumType -> Integer -> Type -> Literal +mkLitNumber platform nt i t = + ASSERT2(litNumCheckRange platform nt i, integer i) + (LitNumber nt i t) + +-- | Creates a 'Literal' of type @Int#@ +mkLitInt :: Platform -> Integer -> Literal +mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x ) + (mkLitIntUnchecked x) + +-- | Creates a 'Literal' of type @Int#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrap :: Platform -> Integer -> Literal +mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i + +-- | Creates a 'Literal' of type @Int#@ without checking its range. +mkLitIntUnchecked :: Integer -> Literal +mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy + +-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating +-- overflow. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the overflow flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitIntWrapC platform i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkLitIntWrap platform i + +-- | Creates a 'Literal' of type @Word#@ +mkLitWord :: Platform -> Integer -> Literal +mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x ) + (mkLitWordUnchecked x) + +-- | Creates a 'Literal' of type @Word#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrap :: Platform -> Integer -> Literal +mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i + +-- | Creates a 'Literal' of type @Word#@ without checking its range. +mkLitWordUnchecked :: Integer -> Literal +mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy + +-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating +-- carry. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the carry flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitWordWrapC platform i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkLitWordWrap platform i + +-- | Creates a 'Literal' of type @Int64#@ +mkLitInt64 :: Integer -> Literal +mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) + +-- | Creates a 'Literal' of type @Int64#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt64Wrap :: Platform -> Integer -> Literal +mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i + +-- | Creates a 'Literal' of type @Int64#@ without checking its range. +mkLitInt64Unchecked :: Integer -> Literal +mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy + +-- | Creates a 'Literal' of type @Word64#@ +mkLitWord64 :: Integer -> Literal +mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) + +-- | Creates a 'Literal' of type @Word64#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord64Wrap :: Platform -> Integer -> Literal +mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i + +-- | Creates a 'Literal' of type @Word64#@ without checking its range. +mkLitWord64Unchecked :: Integer -> Literal +mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy + +-- | Creates a 'Literal' of type @Float#@ +mkLitFloat :: Rational -> Literal +mkLitFloat = LitFloat + +-- | Creates a 'Literal' of type @Double#@ +mkLitDouble :: Rational -> Literal +mkLitDouble = LitDouble + +-- | Creates a 'Literal' of type @Char#@ +mkLitChar :: Char -> Literal +mkLitChar = LitChar + +-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to +-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ +mkLitString :: String -> Literal +-- stored UTF-8 encoded +mkLitString s = LitString (bytesFS $ mkFastString s) + +mkLitInteger :: Integer -> Type -> Literal +mkLitInteger x ty = LitNumber LitNumInteger x ty + +mkLitNatural :: Integer -> Type -> Literal +mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) + (LitNumber LitNumNatural x ty) + +inNaturalRange :: Integer -> Bool +inNaturalRange x = x >= 0 + +inInt64Range, inWord64Range :: Integer -> Bool +inInt64Range x = x >= toInteger (minBound :: Int64) && + x <= toInteger (maxBound :: Int64) +inWord64Range x = x >= toInteger (minBound :: Word64) && + x <= toInteger (maxBound :: Word64) + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +-- | Tests whether the literal represents a zero of whatever type it is +isZeroLit :: Literal -> Bool +isZeroLit (LitNumber _ 0 _) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True +isZeroLit _ = False + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. +litValue :: Literal -> Integer +litValue l = case isLitValue_maybe l of + Just x -> x + Nothing -> pprPanic "litValue" (ppr l) + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char' and numbers. +isLitValue_maybe :: Literal -> Maybe Integer +isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitNumber _ i _) = Just i +isLitValue_maybe _ = Nothing + +-- | Apply a function to the 'Integer' contained in the 'Literal', for when that +-- makes sense, e.g. for 'Char' and numbers. +-- For fixed-size integral literals, the result will be wrapped in accordance +-- with the semantics of the target type. +-- See Note [Word/Int underflow/overflow] +mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) + where fchar = chr . fromInteger . f . toInteger . ord +mapLitValue platform f (LitNumber nt i t) = wrapLitNumber platform + (LitNumber nt (f i) t) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) + +-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', +-- 'Int', 'Word', 'LitInteger' and 'LitNatural'. +isLitValue :: Literal -> Bool +isLitValue = isJust . isLitValue_maybe + +{- + Coercions + ~~~~~~~~~ +-} + +narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, + char2IntLit, int2CharLit, + float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, + float2DoubleLit, double2FloatLit + :: Literal -> Literal + +word2IntLit, int2WordLit :: Platform -> Literal -> Literal +word2IntLit platform (LitNumber LitNumWord w _) + -- Map Word range [max_int+1, max_word] + -- to Int range [min_int , -1] + -- Range [0,max_int] has the same representation with both Int and Word + | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1) + | otherwise = mkLitInt platform w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) + +int2WordLit platform (LitNumber LitNumInt i _) + -- Map Int range [min_int , -1] + -- to Word range [max_int+1, max_word] + -- Range [0,max_int] has the same representation with both Int and Word + | i < 0 = mkLitWord platform (1 + platformMaxWord platform + i) + | otherwise = mkLitWord platform i +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) + +-- | Narrow a literal number (unchecked result range) +narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal +narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t +narrowLit _ l = pprPanic "narrowLit" (ppr l) + +narrow8IntLit = narrowLit (Proxy :: Proxy Int8) +narrow16IntLit = narrowLit (Proxy :: Proxy Int16) +narrow32IntLit = narrowLit (Proxy :: Proxy Int32) +narrow8WordLit = narrowLit (Proxy :: Proxy Word8) +narrow16WordLit = narrowLit (Proxy :: Proxy Word16) +narrow32WordLit = narrowLit (Proxy :: Proxy Word32) + +char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) +char2IntLit l = pprPanic "char2IntLit" (ppr l) +int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) +int2CharLit l = pprPanic "int2CharLit" (ppr l) + +float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) +float2IntLit l = pprPanic "float2IntLit" (ppr l) +int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) +int2FloatLit l = pprPanic "int2FloatLit" (ppr l) + +double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) +double2IntLit l = pprPanic "double2IntLit" (ppr l) +int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) +int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) + +float2DoubleLit (LitFloat f) = LitDouble f +float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) +double2FloatLit (LitDouble d) = LitFloat d +double2FloatLit l = pprPanic "double2FloatLit" (ppr l) + +nullAddrLit :: Literal +nullAddrLit = LitNullAddr + +-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. +rubbishLit :: Literal +rubbishLit = LitRubbish + +{- + Predicates + ~~~~~~~~~~ +-} + +-- | True if there is absolutely no penalty to duplicating the literal. +-- False principally of strings. +-- +-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would +-- blow up code sizes. Not only this, it's also unsafe. +-- +-- Consider a program that wants to traverse a string. One way it might do this +-- is to first compute the Addr# pointing to the end of the string, and then, +-- starting from the beginning, bump a pointer using eqAddr# to determine the +-- end. For instance, +-- +-- @ +-- -- Given pointers to the start and end of a string, count how many zeros +-- -- the string contains. +-- countZeros :: Addr# -> Addr# -> -> Int +-- countZeros start end = go start 0 +-- where +-- go off n +-- | off `addrEq#` end = n +-- | otherwise = go (off `plusAddr#` 1) n' +-- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 +-- | otherwise = n +-- @ +-- +-- Consider what happens if we considered strings to be trivial (and therefore +-- duplicable) and emitted a call like @countZeros "hello"# ("hello"# +-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same +-- string, meaning that an iteration like the above would blow up terribly. +-- This is what happened in #12757. +-- +-- Ultimately the solution here is to make primitive strings a bit more +-- structured, ensuring that the compiler can't inline in ways that will break +-- user code. One approach to this is described in #8472. +litIsTrivial :: Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsTrivial +litIsTrivial (LitString _) = False +litIsTrivial (LitNumber nt _ _) = case nt of + LitNumInteger -> False + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True +litIsTrivial _ = True + +-- | True if code space does not go bad if we duplicate this literal +litIsDupable :: Platform -> Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsDupable +litIsDupable platform x = case x of + (LitNumber nt i _) -> case nt of + LitNumInteger -> platformInIntRange platform i + LitNumNatural -> platformInWordRange platform i + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True + (LitString _) -> False + _ -> True + +litFitsInChar :: Literal -> Bool +litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False + +litIsLifted :: Literal -> Bool +litIsLifted (LitNumber nt _ _) = case nt of + LitNumInteger -> True + LitNumNatural -> True + LitNumInt -> False + LitNumInt64 -> False + LitNumWord -> False + LitNumWord64 -> False +litIsLifted _ = False + +{- + Types + ~~~~~ + +Note [Types of LitNumbers] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A LitNumber's type is always known from its LitNumType: + + LitNumInteger -> Integer + LitNumNatural -> Natural + LitNumInt -> Int# (intPrimTy) + LitNumInt64 -> Int64# (int64PrimTy) + LitNumWord -> Word# (wordPrimTy) + LitNumWord64 -> Word64# (word64PrimTy) + +The reason why we have a Type field is because Integer and Natural types live +outside of GHC (in the libraries), so we have to get the actual Type via +lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites +of literalType, so we do that when creating these literals, and literalType +simply reads the field. + +(But see also Note [Integer literals] and Note [Natural literals]) +-} + +-- | Find the Haskell 'Type' the literal occupies +literalType :: Literal -> Type +literalType LitNullAddr = addrPrimTy +literalType (LitChar _) = charPrimTy +literalType (LitString _) = addrPrimTy +literalType (LitFloat _) = floatPrimTy +literalType (LitDouble _) = doublePrimTy +literalType (LitLabel _ _ _) = addrPrimTy +literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] +literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) + where + a = alphaTyVarUnliftedRep + +absentLiteralOf :: TyCon -> Maybe Literal +-- Return a literal of the appropriate primitive +-- TyCon, to use as a placeholder when it doesn't matter +-- Rubbish literals are handled in GHC.Core.Op.WorkWrap.Lib, because +-- 1. Looking at the TyCon is not enough, we need the actual type +-- 2. This would need to return a type application to a literal +absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) + +absent_lits :: UniqFM Literal +absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) + , (charPrimTyConKey, LitChar 'x') + , (intPrimTyConKey, mkLitIntUnchecked 0) + , (int64PrimTyConKey, mkLitInt64Unchecked 0) + , (wordPrimTyConKey, mkLitWordUnchecked 0) + , (word64PrimTyConKey, mkLitWord64Unchecked 0) + , (floatPrimTyConKey, LitFloat 0) + , (doublePrimTyConKey, LitDouble 0) + ] + +{- + Comparison + ~~~~~~~~~~ +-} + +cmpLit :: Literal -> Literal -> Ordering +cmpLit (LitChar a) (LitChar b) = a `compare` b +cmpLit (LitString a) (LitString b) = a `compare` b +cmpLit (LitNullAddr) (LitNullAddr) = EQ +cmpLit (LitFloat a) (LitFloat b) = a `compare` b +cmpLit (LitDouble a) (LitDouble b) = a `compare` b +cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b +cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) + | nt1 == nt2 = a `compare` b + | otherwise = nt1 `compare` nt2 +cmpLit (LitRubbish) (LitRubbish) = EQ +cmpLit lit1 lit2 + | litTag lit1 < litTag lit2 = LT + | otherwise = GT + +litTag :: Literal -> Int +litTag (LitChar _) = 1 +litTag (LitString _) = 2 +litTag (LitNullAddr) = 3 +litTag (LitFloat _) = 4 +litTag (LitDouble _) = 5 +litTag (LitLabel _ _ _) = 6 +litTag (LitNumber {}) = 7 +litTag (LitRubbish) = 8 + +{- + Printing + ~~~~~~~~ +* See Note [Printing of literals in Core] +-} + +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +pprLiteral _ (LitChar c) = pprPrimChar c +pprLiteral _ (LitString s) = pprHsBytes s +pprLiteral _ (LitNullAddr) = text "__NULL" +pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix +pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix +pprLiteral add_par (LitNumber nt i _) + = case nt of + LitNumInteger -> pprIntegerVal add_par i + LitNumNatural -> pprIntegerVal add_par i + LitNumInt -> pprPrimInt i + LitNumInt64 -> pprPrimInt64 i + LitNumWord -> pprPrimWord i + LitNumWord64 -> pprPrimWord64 i +pprLiteral add_par (LitLabel l mb fod) = + add_par (text "__label" <+> b <+> ppr fod) + where b = case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) +pprLiteral _ (LitRubbish) = text "__RUBBISH" + +pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc +-- See Note [Printing of literals in Core]. +pprIntegerVal add_par i | i < 0 = add_par (integer i) + | otherwise = integer i + +{- +Note [Printing of literals in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function `add_par` is used to wrap parenthesis around negative integers +(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring +an atomic thing (for example function application). + +Although not all Core literals would be valid Haskell, we are trying to stay +as close as possible to Haskell syntax in the printing of Core, to make it +easier for a Haskell user to read Core. + +To that end: + * We do print parenthesis around negative `LitInteger`, because we print + `LitInteger` using plain number literals (no prefix or suffix), and plain + number literals in Haskell require parenthesis in contexts like function + application (i.e. `1 - -1` is not valid Haskell). + + * We don't print parenthesis around other (negative) literals, because they + aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's + parser). + +Literal Output Output if context requires + an atom (if different) +------- ------- ---------------------- +LitChar 'a'# +LitString "aaa"# +LitNullAddr "__NULL" +LitInt -1# +LitInt64 -1L# +LitWord 1## +LitWord64 1L## +LitFloat -1.0# +LitDouble -1.0## +LitInteger -1 (-1) +LitLabel "__label" ... ("__label" ...) +LitRubbish "__RUBBISH" + +Note [Rubbish literals] +~~~~~~~~~~~~~~~~~~~~~~~ +During worker/wrapper after demand analysis, where an argument +is unused (absent) we do the following w/w split (supposing that +y is absent): + + f x y z = e +===> + f x y z = $wf x z + $wf x z = let y = + in e + +Usually the binding for y is ultimately optimised away, and +even if not it should never be evaluated -- but that's the +way the w/w split starts off. + +What is ? +* For lifted values can be a call to 'error'. +* For primitive types like Int# or Word# we can use any random + value of that type. +* But what about /unlifted/ but /boxed/ types like MutVar# or + Array#? We need a literal value of that type. + +That is 'LitRubbish'. Since we need a rubbish literal for +many boxed, unlifted types, we say that LitRubbish has type + LitRubbish :: forall (a :: TYPE UnliftedRep). a + +So we might see a w/w split like + $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) + in e + +Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted +heap pointers. + +Here are the moving parts: + +* We define LitRubbish as a constructor in GHC.Types.Literal.Literal + +* It is given its polymorphic type by Literal.literalType + +* GHC.Core.Op.WorkWrap.Lib.mk_absent_let introduces a LitRubbish for absent + arguments of boxed, unlifted type. + +* In CoreToSTG we convert (RubishLit @t) to just (). STG is + untyped, so it doesn't matter that it points to a lifted + value. The important thing is that it is a heap pointer, + which the garbage collector can follow if it encounters it. + + We considered maintaining LitRubbish in STG, and lowering + it in the code generators, but it seems simpler to do it + once and for all in CoreToSTG. + + In GHC.ByteCode.Asm we just lower it as a 0 literal, because + it's all boxed and lifted to the host GC anyway. +-} diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Module.hs @@ -0,0 +1,1322 @@ +{- +(c) The University of Glasgow, 2004-2006 + + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build Maps with Modules as +the keys. +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHC.Types.Module + ( + -- * The ModuleName type + ModuleName, + pprModuleName, + moduleNameFS, + moduleNameString, + moduleNameSlashes, moduleNameColons, + moduleStableString, + moduleFreeHoles, + moduleIsDefinite, + mkModuleName, + mkModuleNameFS, + stableModuleNameCmp, + + -- * The UnitId type + ComponentId(..), + ComponentDetails(..), + UnitId(..), + unitIdFS, + unitIdKey, + IndefUnitId(..), + IndefModule(..), + indefUnitIdToUnitId, + indefModuleToModule, + InstalledUnitId(..), + toInstalledUnitId, + ShHoleSubst, + + unitIdIsDefinite, + unitIdString, + unitIdFreeHoles, + + newUnitId, + newIndefUnitId, + newSimpleUnitId, + hashUnitId, + fsToUnitId, + stringToUnitId, + stableUnitIdCmp, + + -- * HOLE renaming + renameHoleUnitId, + renameHoleModule, + renameHoleUnitId', + renameHoleModule', + + -- * Generalization + splitModuleInsts, + splitUnitIdInsts, + generalizeIndefUnitId, + generalizeIndefModule, + + -- * Parsers + parseModuleName, + parseUnitId, + parseComponentId, + parseModuleId, + parseModSubst, + + -- * Wired-in UnitIds + -- $wired_in_packages + primUnitId, + integerUnitId, + baseUnitId, + rtsUnitId, + thUnitId, + mainUnitId, + thisGhcUnitId, + isHoleModule, + interactiveUnitId, isInteractiveModule, + wiredInUnitIds, + + -- * The Module type + Module(Module), + moduleUnitId, moduleName, + pprModule, + mkModule, + mkHoleModule, + stableModuleCmp, + HasModule(..), + ContainsModule(..), + + -- * Installed unit ids and modules + InstalledModule(..), + InstalledModuleEnv, + installedModuleEq, + installedUnitIdEq, + installedUnitIdString, + fsToInstalledUnitId, + componentIdToInstalledUnitId, + stringToInstalledUnitId, + emptyInstalledModuleEnv, + lookupInstalledModuleEnv, + extendInstalledModuleEnv, + filterInstalledModuleEnv, + delInstalledModuleEnv, + DefUnitId(..), + + -- * The ModuleLocation type + ModLocation(..), + addBootSuffix, addBootSuffix_maybe, + addBootSuffixLocn, addBootSuffixLocnOut, + + -- * Module mappings + ModuleEnv, + elemModuleEnv, extendModuleEnv, extendModuleEnvList, + extendModuleEnvList_C, plusModuleEnv_C, + delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, + lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, + moduleEnvKeys, moduleEnvElts, moduleEnvToList, + unitModuleEnv, isEmptyModuleEnv, + extendModuleEnvWith, filterModuleEnv, + + -- * ModuleName mappings + ModuleNameEnv, DModuleNameEnv, + + -- * Sets of Modules + ModuleSet, + emptyModuleSet, mkModuleSet, moduleSetElts, + extendModuleSet, extendModuleSetList, delModuleSet, + elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, + unitModuleSet + ) where + +import GhcPrelude + +import Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet +import FastString +import Binary +import Util +import Data.List (sortBy, sort) +import Data.Ord +import Data.Version +import GHC.PackageDb +import Fingerprint + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.Char8 +import Encoding + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) +import Control.DeepSeq +import Data.Coerce +import Data.Data +import Data.Function +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified FiniteMap as Map +import System.FilePath + +import {-# SOURCE #-} GHC.Driver.Session (DynFlags) +import {-# SOURCE #-} GHC.Driver.Packages (improveUnitId, componentIdString, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId, getPackageState) + +-- Note [The identifier lexicon] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Unit IDs, installed package IDs, ABI hashes, package names, +-- versions, there are a *lot* of different identifiers for closely +-- related things. What do they all mean? Here's what. (See also +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) +-- +-- THE IMPORTANT ONES +-- +-- ComponentId: An opaque identifier provided by Cabal, which should +-- uniquely identify such things as the package name, the package +-- version, the name of the component, the hash of the source code +-- tarball, the selected Cabal flags, GHC flags, direct dependencies of +-- the component. These are very similar to InstalledPackageId, but +-- an 'InstalledPackageId' implies that it identifies a package, while +-- a package may install multiple components with different +-- 'ComponentId's. +-- - Same as Distribution.Package.ComponentId +-- +-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names +-- (ModuleName) to Modules. This is how the compiler identifies instantiated +-- components, and also is the main identifier by which GHC identifies things. +-- - When Backpack is not being used, UnitId = ComponentId. +-- this means a useful fiction for end-users is that there are +-- only ever ComponentIds, and some ComponentIds happen to have +-- more information (UnitIds). +-- - Same as Language.Haskell.TH.Syntax:PkgName, see +-- https://gitlab.haskell.org/ghc/ghc/issues/10279 +-- - The same as PackageKey in GHC 7.10 (we renamed it because +-- they don't necessarily identify packages anymore.) +-- - Same as -this-package-key/-package-name flags +-- - An InstalledUnitId corresponds to an actual package which +-- we have installed on disk. It could be definite or indefinite, +-- but if it's indefinite, it has nothing instantiated (we +-- never install partially instantiated units.) +-- +-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how +-- the compiler identifies modules (e.g. a Name is a Module + OccName) +-- - Same as Language.Haskell.TH.Syntax:Module +-- +-- THE LESS IMPORTANT ONES +-- +-- PackageName: The "name" field in a Cabal file, something like "lens". +-- - Same as Distribution.Package.PackageName +-- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see +-- https://gitlab.haskell.org/ghc/ghc/issues/10279 +-- - DIFFERENT FROM -package-name flag +-- - DIFFERENT FROM the 'name' field in an installed package +-- information. This field could more accurately be described +-- as a munged package name: when it's for the main library +-- it is the same as the package name, but if it's an internal +-- library it's a munged combination of the package name and +-- the component name. +-- +-- LEGACY ONES +-- +-- InstalledPackageId: This is what we used to call ComponentId. +-- It's a still pretty useful concept for packages that have only +-- one library; in that case the logical InstalledPackageId = +-- ComponentId. Also, the Cabal nix-local-build continues to +-- compute an InstalledPackageId which is then forcibly used +-- for all components in a package. This means that if a dependency +-- from one component in a package changes, the InstalledPackageId +-- changes: you don't get as fine-grained dependency tracking, +-- but it means your builds are hermetic. Eventually, Cabal will +-- deal completely in components and we can get rid of this. +-- +-- PackageKey: This is what we used to call UnitId. We ditched +-- "Package" from the name when we realized that you might want to +-- assign different "PackageKeys" to components from the same package. +-- (For a brief, non-released period of time, we also called these +-- UnitKeys). + +{- +************************************************************************ +* * +\subsection{Module locations} +* * +************************************************************************ +-} + +-- | Module Location +-- +-- Where a module lives on the file system: the actual locations +-- of the .hs, .hi and .o files, if we have them +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath, + -- Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- package with a .a file) + ml_hie_file :: FilePath + } deriving Show + +instance Outputable ModLocation where + ppr = text . show + +{- +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. +-} + +addBootSuffix :: FilePath -> FilePath +-- ^ Add the @-boot@ suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all file paths associated with the module +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +addBootSuffixLocnOut :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut locn + = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +{- +************************************************************************ +* * +\subsection{The name of a module} +* * +************************************************************************ +-} + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString + +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + +instance Eq ModuleName where + nm1 == nm2 = getUnique nm1 == getUnique nm2 + +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + +instance Outputable ModuleName where + ppr = pprModuleName + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +instance BinaryStringRep ModuleName where + fromStringRep = mkModuleNameFS . mkFastStringByteString + toStringRep = bytesFS . moduleNameFS + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 + +pprModuleName :: ModuleName -> SDoc +pprModuleName (ModuleName nm) = + getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS nm) + else ftext nm + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +-- | Get a string representation of a 'Module' that's unique and stable +-- across recompilations. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" +moduleStableString :: Module -> String +moduleStableString Module{..} = + "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +{- +************************************************************************ +* * +\subsection{A fully qualified module} +* * +************************************************************************ +-} + +-- | A Module is a pair of a 'UnitId' and a 'ModuleName'. +-- +-- Module variables (i.e. @@) which can be instantiated to a +-- specific module at some later point in time are represented +-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to +-- avoid having to make 'moduleUnitId' a partial operation.) +-- +data Module = Module { + moduleUnitId :: !UnitId, -- pkg-1.0 + moduleName :: !ModuleName -- A.B.C + } + deriving (Eq, Ord) + +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: Module -> UniqDSet ModuleName +moduleFreeHoles m + | isHoleModule m = unitUniqDSet (moduleName m) + | otherwise = unitIdFreeHoles (moduleUnitId m) + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Create a module variable at some 'ModuleName'. +-- See Note [Representation of module/name variables] +mkHoleModule :: ModuleName -> Module +mkHoleModule = mkModule holeUnitId + +instance Uniquable Module where + getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) + +instance Outputable Module where + ppr = pprModule + +instance Binary Module where + put_ bh (Module p n) = put_ bh p >> put_ bh n + get bh = do p <- get bh; n <- get bh; return (Module p n) + +instance Data Module where + -- don't traverse? + toConstr _ = abstractConstr "Module" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Module" + +instance NFData Module where + rnf x = x `seq` () + +-- | This gives a stable ordering, as opposed to the Ord instance which +-- gives an ordering based on the 'Unique's of the components, which may +-- not be stable from run to run of the compiler. +stableModuleCmp :: Module -> Module -> Ordering +stableModuleCmp (Module p1 n1) (Module p2 n2) + = (p1 `stableUnitIdCmp` p2) `thenCmp` + (n1 `stableModuleNameCmp` n2) + +mkModule :: UnitId -> ModuleName -> Module +mkModule = Module + +pprModule :: Module -> SDoc +pprModule mod@(Module p n) = getPprStyle doc + where + doc sty + | codeStyle sty = + (if p == mainUnitId + then empty -- never qualify the main package in code + else ztext (zEncodeFS (unitIdFS p)) <> char '_') + <> pprModuleName n + | qualModule sty mod = + if isHoleModule mod + then angleBrackets (pprModuleName n) + else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module + +instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where + fromDbModule (DbModule uid mod_name) = mkModule uid mod_name + fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name + fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts + fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) + -- GHC never writes to the database, so it's not needed + toDbModule = error "toDbModule: not implemented" + toDbUnitId = error "toDbUnitId: not implemented" + +{- +************************************************************************ +* * +\subsection{ComponentId} +* * +************************************************************************ +-} + +-- | A 'ComponentId' consists of the package name, package version, component +-- ID, the transitive dependencies of the component, and other information to +-- uniquely identify the source code and build configuration of a component. +-- +-- This used to be known as an 'InstalledPackageId', but a package can contain +-- multiple components and a 'ComponentId' uniquely identifies a component +-- within a package. When a package only has one component, the 'ComponentId' +-- coincides with the 'InstalledPackageId' +data ComponentId = ComponentId + { componentIdRaw :: FastString -- ^ Raw + , componentIdDetails :: Maybe ComponentDetails -- ^ Cache of component details retrieved from the DB + } + +instance Eq ComponentId where + a == b = componentIdRaw a == componentIdRaw b + +instance Ord ComponentId where + compare a b = compare (componentIdRaw a) (componentIdRaw b) + +data ComponentDetails = ComponentDetails + { componentPackageName :: String + , componentPackageVersion :: Version + , componentName :: Maybe String + , componentSourcePkdId :: String + } + +instance BinaryStringRep ComponentId where + fromStringRep bs = ComponentId (mkFastStringByteString bs) Nothing + toStringRep (ComponentId s _) = bytesFS s + +instance Uniquable ComponentId where + getUnique (ComponentId n _) = getUnique n + +instance Outputable ComponentId where + ppr cid@(ComponentId fs _) = + getPprStyle $ \sty -> + if debugStyle sty + then ftext fs + else text (componentIdString cid) + + + +{- +************************************************************************ +* * +\subsection{UnitId} +* * +************************************************************************ +-} + +-- | A unit identifier identifies a (possibly partially) instantiated +-- library. It is primarily used as part of 'Module', which in turn +-- is used in 'Name', which is used to give names to entities when +-- typechecking. +-- +-- There are two possible forms for a 'UnitId'. It can be a +-- 'DefiniteUnitId', in which case we just have a string that uniquely +-- identifies some fully compiled, installed library we have on disk. +-- However, when we are typechecking a library with missing holes, +-- we may need to instantiate a library on the fly (in which case +-- we don't have any on-disk representation.) In that case, you +-- have an 'IndefiniteUnitId', which explicitly records the +-- instantiation, so that we can substitute over it. +data UnitId + = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId + | DefiniteUnitId {-# UNPACK #-} !DefUnitId + +unitIdFS :: UnitId -> FastString +unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x +unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x + +unitIdKey :: UnitId -> Unique +unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x +unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x + +-- | A unit identifier which identifies an indefinite +-- library (with holes) that has been *on-the-fly* instantiated +-- with a substitution 'indefUnitIdInsts'. In fact, an indefinite +-- unit identifier could have no holes, but we haven't gotten +-- around to compiling the actual library yet. +-- +-- An indefinite unit identifier pretty-prints to something like +-- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the +-- brackets enclose the module substitution). +data IndefUnitId + = IndefUnitId { + -- | A private, uniquely identifying representation of + -- a UnitId. This string is completely private to GHC + -- and is just used to get a unique; in particular, we don't use it for + -- symbols (indefinite libraries are not compiled). + indefUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + indefUnitIdKey :: Unique, + -- | The component identity of the indefinite library that + -- is being instantiated. + indefUnitIdComponentId :: !ComponentId, + -- | The sorted (by 'ModuleName') instantiations of this library. + indefUnitIdInsts :: ![(ModuleName, Module)], + -- | A cache of the free module variables of 'unitIdInsts'. + -- This lets us efficiently tell if a 'UnitId' has been + -- fully instantiated (free module variables are empty) + -- and whether or not a substitution can have any effect. + indefUnitIdFreeHoles :: UniqDSet ModuleName + } + +instance Eq IndefUnitId where + u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 + +instance Ord IndefUnitId where + u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 + +instance Binary IndefUnitId where + put_ bh indef = do + put_ bh (indefUnitIdComponentId indef) + put_ bh (indefUnitIdInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = hashUnitId cid insts + return IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + +-- | Create a new 'IndefUnitId' given an explicit module substitution. +newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId +newIndefUnitId cid insts = + IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = sorted_insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + where + fs = hashUnitId cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + +-- | Injects an 'IndefUnitId' (indefinite library which +-- was on-the-fly instantiated) to a 'UnitId' (either +-- an indefinite or definite library). +indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId +indefUnitIdToUnitId dflags iuid = + -- NB: suppose that we want to compare the indefinite + -- unit id p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- IndefiniteUnitId, they won't compare equal; only + -- after improvement will the equality hold. + improveUnitId (getUnitInfoMap dflags) $ + IndefiniteUnitId iuid + +data IndefModule = IndefModule { + indefModuleUnitId :: IndefUnitId, + indefModuleName :: ModuleName + } deriving (Eq, Ord) + +instance Outputable IndefModule where + ppr (IndefModule uid m) = + ppr uid <> char ':' <> ppr m + +-- | Injects an 'IndefModule' to 'Module' (see also +-- 'indefUnitIdToUnitId'. +indefModuleToModule :: DynFlags -> IndefModule -> Module +indefModuleToModule dflags (IndefModule iuid mod_name) = + mkModule (indefUnitIdToUnitId dflags iuid) mod_name + +-- | An installed unit identifier identifies a library which has +-- been installed to the package database. These strings are +-- provided to us via the @-this-unit-id@ flag. The library +-- in question may be definite or indefinite; if it is indefinite, +-- none of the holes have been filled (we never install partially +-- instantiated libraries.) Put another way, an installed unit id +-- is either fully instantiated, or not instantiated at all. +-- +-- Installed unit identifiers look something like @p+af23SAj2dZ219@, +-- or maybe just @p@ if they don't use Backpack. +newtype InstalledUnitId = + InstalledUnitId { + -- | The full hashed unit identifier, including the component id + -- and the hash. + installedUnitIdFS :: FastString + } + +instance Binary InstalledUnitId where + put_ bh (InstalledUnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (InstalledUnitId fs) + +instance BinaryStringRep InstalledUnitId where + fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) + -- GHC doesn't write to database + toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" + +instance Eq InstalledUnitId where + uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 + +instance Ord InstalledUnitId where + u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 + +instance Uniquable InstalledUnitId where + getUnique = installedUnitIdKey + +instance Outputable InstalledUnitId where + ppr uid@(InstalledUnitId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case displayInstalledUnitId (getPackageState dflags) uid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs + +installedUnitIdKey :: InstalledUnitId -> Unique +installedUnitIdKey = getUnique . installedUnitIdFS + +-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. +toInstalledUnitId :: UnitId -> InstalledUnitId +toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid +toInstalledUnitId (IndefiniteUnitId indef) = + componentIdToInstalledUnitId (indefUnitIdComponentId indef) + +installedUnitIdString :: InstalledUnitId -> String +installedUnitIdString = unpackFS . installedUnitIdFS + +instance Outputable IndefUnitId where + ppr uid = + -- getPprStyle $ \sty -> + ppr cid <> + (if not (null insts) -- pprIf + then + brackets (hcat + (punctuate comma $ + [ ppr modname <> text "=" <> ppr m + | (modname, m) <- insts])) + else empty) + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + +-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. +data InstalledModule = InstalledModule { + installedModuleUnitId :: !InstalledUnitId, + installedModuleName :: !ModuleName + } + deriving (Eq, Ord) + +instance Outputable InstalledModule where + ppr (InstalledModule p n) = + ppr p <> char ':' <> pprModuleName n + +fsToInstalledUnitId :: FastString -> InstalledUnitId +fsToInstalledUnitId fs = InstalledUnitId fs + +componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId +componentIdToInstalledUnitId (ComponentId fs _) = fsToInstalledUnitId fs + +stringToInstalledUnitId :: String -> InstalledUnitId +stringToInstalledUnitId = fsToInstalledUnitId . mkFastString + +-- | Test if a 'Module' corresponds to a given 'InstalledModule', +-- modulo instantiation. +installedModuleEq :: InstalledModule -> Module -> Bool +installedModuleEq imod mod = + fst (splitModuleInsts mod) == imod + +-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', +-- modulo instantiation. +installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool +installedUnitIdEq iuid uid = + fst (splitUnitIdInsts uid) == iuid + +-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that +-- it only refers to a definite library; i.e., one we have generated +-- code for. +newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } + deriving (Eq, Ord) + +instance Outputable DefUnitId where + ppr (DefUnitId uid) = ppr uid + +instance Binary DefUnitId where + put_ bh (DefUnitId uid) = put_ bh uid + get bh = do uid <- get bh; return (DefUnitId uid) + +-- | A map keyed off of 'InstalledModule' +newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) + +emptyInstalledModuleEnv :: InstalledModuleEnv a +emptyInstalledModuleEnv = InstalledModuleEnv Map.empty + +lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a +lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e + +extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a +extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) + +filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a +filterInstalledModuleEnv f (InstalledModuleEnv e) = + InstalledModuleEnv (Map.filterWithKey f e) + +delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a +delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) + +-- Note [UnitId to InstalledUnitId improvement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Just because a UnitId is definite (has no holes) doesn't +-- mean it's necessarily a InstalledUnitId; it could just be +-- that over the course of renaming UnitIds on the fly +-- while typechecking an indefinite library, we +-- ended up with a fully instantiated unit id with no hash, +-- since we haven't built it yet. This is fine. +-- +-- However, if there is a hashed unit id for this instantiation +-- in the package database, we *better use it*, because +-- that hashed unit id may be lurking in another interface, +-- and chaos will ensue if we attempt to compare the two +-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided +-- hash of a compiled instantiated library). +-- +-- There is one last niggle: improvement based on the package database means +-- that we might end up developing on a package that is not transitively +-- depended upon by the packages the user specified directly via command line +-- flags. This could lead to strange and difficult to understand bugs if those +-- instantiations are out of date. The solution is to only improve a +-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the +-- closure of all the packages which were explicitly specified. + +-- | Retrieve the set of free holes of a 'UnitId'. +unitIdFreeHoles :: UnitId -> UniqDSet ModuleName +unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x +-- Hashed unit ids are always fully instantiated +unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet + +instance Show UnitId where + show = unitIdString + +-- | A 'UnitId' is definite if it has no free holes. +unitIdIsDefinite :: UnitId -> Bool +unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles + +-- | Generate a uniquely identifying 'FastString' for a unit +-- identifier. This is a one-way function. You can rely on one special +-- property: if a unit identifier is in most general form, its 'FastString' +-- coincides with its 'ComponentId'. This hash is completely internal +-- to GHC and is not used for symbol names or file paths. +hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString +hashUnitId cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (toStringRep cid) + $ rawHashUnitId sorted_holes + +-- | Generate a hash for a sorted module substitution. +rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint +rawHashUnitId sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ toStringRep m, BS.Char8.singleton ' ', + bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', + toStringRep (moduleName b), BS.Char8.singleton '\n'] + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +-- | Create a new, un-hashed unit identifier. +newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId +newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... +newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts + +pprUnitId :: UnitId -> SDoc +pprUnitId (DefiniteUnitId uid) = ppr uid +pprUnitId (IndefiniteUnitId uid) = ppr uid + +instance Eq UnitId where + uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 + +instance Uniquable UnitId where + getUnique = unitIdKey + +instance Ord UnitId where + nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 + +instance Data UnitId where + -- don't traverse? + toConstr _ = abstractConstr "UnitId" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "UnitId" + +instance NFData UnitId where + rnf x = x `seq` () + +stableUnitIdCmp :: UnitId -> UnitId -> Ordering +-- ^ Compares package ids lexically, rather than by their 'Unique's +stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 + +instance Outputable UnitId where + ppr pk = pprUnitId pk + +-- Performance: would prefer to have a NameCache like thing +instance Binary UnitId where + put_ bh (DefiniteUnitId def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (IndefiniteUnitId indef_uid) = do + putByte bh 1 + put_ bh indef_uid + get bh = do b <- getByte bh + case b of + 0 -> fmap DefiniteUnitId (get bh) + _ -> fmap IndefiniteUnitId (get bh) + +instance Binary ComponentId where + put_ bh (ComponentId fs _) = put_ bh fs + get bh = do { fs <- get bh; return (ComponentId fs Nothing) } + +-- | Create a new simple unit identifier (no holes) from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId (ComponentId fs _) = fsToUnitId fs + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnitId :: FastString -> UnitId +fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId + +stringToUnitId :: String -> UnitId +stringToUnitId = fsToUnitId . mkFastString + +unitIdString :: UnitId -> String +unitIdString = unpackFS . unitIdFS + +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variable]. +-- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @@ maps to @q():A@. +renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module +renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags) + +-- | Substitutes holes in a 'UnitId', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variable]. +-- +-- @p[A=]@ maps to @p[A=]@ with @A=@. +renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags) + +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' +-- so it can be used by "Packages". +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = , that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap' +-- so it can be used by "Packages". +renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId' pkg_map env uid = + case uid of + (IndefiniteUnitId + IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts + , indefUnitIdFreeHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'UnitInfoMap' to see if there is + -- a compiled version of this 'UnitId' we can improve to. + -- See Note [UnitId to InstalledUnitId] improvement + else improveUnitId pkg_map $ + newUnitId cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) +splitModuleInsts m = + let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) + in (InstalledModule uid (moduleName m), + fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) + +-- | See 'splitModuleInsts'. +splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) +splitUnitIdInsts (IndefiniteUnitId iuid) = + (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) +splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) + +generalizeIndefUnitId :: IndefUnitId -> IndefUnitId +generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts } = + newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) + +generalizeIndefModule :: IndefModule -> IndefModule +generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n + +parseModuleName :: ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + +parseUnitId :: ReadP UnitId +parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId + where + parseFullUnitId = do + cid <- parseComponentId + insts <- parseModSubst + return (newUnitId cid insts) + parseDefiniteUnitId = do + s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + return (stringToUnitId s) + parseSimpleUnitId = do + cid <- parseComponentId + return (newSimpleUnitId cid) + +parseComponentId :: ReadP ComponentId +parseComponentId = (flip ComponentId Nothing . mkFastString) `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +parseModuleId :: ReadP Module +parseModuleId = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (mkHoleModule modname) + parseModule = do + uid <- parseUnitId + _ <- Parse.char ':' + modname <- parseModuleName + return (mkModule uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseModuleId + return (k, v) + + +{- +Note [Wired-in packages] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Certain packages are known to the compiler, in that we know about certain +entities that reside in these packages, and the compiler needs to +declare static Modules and Names that refer to these packages. Hence +the wired-in packages can't include version numbers in their package UnitId, +since we don't want to bake the version numbers of these packages into GHC. + +So here's the plan. Wired-in packages are still versioned as +normal in the packages database, and you can still have multiple +versions of them installed. To the user, everything looks normal. + +However, for each invocation of GHC, only a single instance of each wired-in +package will be recognised (the desired one is selected via +@-package@\/@-hide-package@), and GHC will internally pretend that it has the +*unversioned* 'UnitId', including in .hi files and object file symbols. + +Unselected versions of wired-in packages will be ignored, as will any other +package that depends directly or indirectly on it (much as if you +had used @-ignore-package@). + +The affected packages are compiled with, e.g., @-this-unit-id base@, so that +the symbols in the object files have the unversioned unit id in their name. + +Make sure you change 'Packages.findWiredInPackages' if you add an entry here. + +For `integer-gmp`/`integer-simple` we also change the base name to +`integer-wired-in`, but this is fundamentally no different. +See Note [The integer library] in PrelNames. +-} + +integerUnitId, primUnitId, + baseUnitId, rtsUnitId, + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId +primUnitId = fsToUnitId (fsLit "ghc-prim") +integerUnitId = fsToUnitId (fsLit "integer-wired-in") + -- See Note [The integer library] in PrelNames +baseUnitId = fsToUnitId (fsLit "base") +rtsUnitId = fsToUnitId (fsLit "rts") +thUnitId = fsToUnitId (fsLit "template-haskell") +thisGhcUnitId = fsToUnitId (fsLit "ghc") +interactiveUnitId = fsToUnitId (fsLit "interactive") + +-- | This is the package Id for the current program. It is the default +-- package Id if you don't specify a package name. We don't add this prefix +-- to symbol names, since there can be only one main package per program. +mainUnitId = fsToUnitId (fsLit "main") + +-- | This is a fake package id used to provide identities to any un-implemented +-- signatures. The set of hole identities is global over an entire compilation. +-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. +-- See Note [Representation of module/name variables] +holeUnitId :: UnitId +holeUnitId = fsToUnitId (fsLit "hole") + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = moduleUnitId mod == interactiveUnitId + +-- Note [Representation of module/name variables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In our ICFP'16, we use to represent module holes, and {A.T} to represent +-- name holes. This could have been represented by adding some new cases +-- to the core data types, but this would have made the existing 'nameModule' +-- and 'moduleUnitId' partial, which would have required a lot of modifications +-- to existing code. +-- +-- Instead, we adopted the following encoding scheme: +-- +-- ===> hole:A +-- {A.T} ===> hole:A.T +-- +-- This encoding is quite convenient, but it is also a bit dangerous too, +-- because if you have a 'hole:A' you need to know if it's actually a +-- 'Module' or just a module stored in a 'Name'; these two cases must be +-- treated differently when doing substitutions. 'renameHoleModule' +-- and 'renameHoleUnitId' assume they are NOT operating on a +-- 'Name'; 'NameShape' handles name substitutions exclusively. + +isHoleModule :: Module -> Bool +isHoleModule mod = moduleUnitId mod == holeUnitId + +wiredInUnitIds :: [UnitId] +wiredInUnitIds = [ primUnitId, + integerUnitId, + baseUnitId, + rtsUnitId, + thUnitId, + thisGhcUnitId ] + +{- +************************************************************************ +* * +\subsection{@ModuleEnv@s} +* * +************************************************************************ +-} + +-- | A map keyed off of 'Module's +newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + +{- +Note [ModuleEnv performance and determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To prevent accidental reintroduction of nondeterminism the Ord instance +for Module was changed to not depend on Unique ordering and to use the +lexicographic order. This is potentially expensive, but when measured +there was no difference in performance. + +To be on the safe side and not pessimize ModuleEnv uses nondeterministic +ordering on Module and normalizes by doing the lexicographic sort when +turning the env to a list. +See Note [Unique Determinism] for more information about the source of +nondeterminismand and Note [Deterministic UniqFM] for explanation of why +it matters for maps. +-} + +newtype NDModule = NDModule { unNDModule :: Module } + deriving Eq + -- A wrapper for Module with faster nondeterministic Ord. + -- Don't export, See [ModuleEnv performance and determinism] + +instance Ord NDModule where + compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = + (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique n1 `nonDetCmpUnique` getUnique n2) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) + +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a + -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = + ModuleEnv (Map.insertWith f (NDModule m) x e) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = + ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = + ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = + ModuleEnv (Map.unionWith f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = + ModuleEnv (Map.deleteList (map NDModule ms) e) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e + +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +lookupWithDefaultModuleEnv (ModuleEnv e) x m = + Map.findWithDefault x (NDModule m) e + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv Map.empty + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts e = map snd $ moduleEnvToList e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = + sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] + -- See Note [ModuleEnv performance and determinism] + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = Map.null e + +-- | A set of 'Module's +type ModuleSet = Set NDModule + +mkModuleSet :: [Module] -> ModuleSet +mkModuleSet = Set.fromList . coerce + +extendModuleSet :: ModuleSet -> Module -> ModuleSet +extendModuleSet s m = Set.insert (NDModule m) s + +extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet +extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms + +emptyModuleSet :: ModuleSet +emptyModuleSet = Set.empty + +moduleSetElts :: ModuleSet -> [Module] +moduleSetElts = sort . coerce . Set.toList + +elemModuleSet :: Module -> ModuleSet -> Bool +elemModuleSet = Set.member . coerce + +intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +intersectModuleSet = coerce Set.intersection + +minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +minusModuleSet = coerce Set.difference + +delModuleSet :: ModuleSet -> Module -> ModuleSet +delModuleSet = coerce (flip Set.delete) + +unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +unionModuleSet = coerce Set.union + +unitModuleSet :: Module -> ModuleSet +unitModuleSet = coerce Set.singleton + +{- +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. +-} + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +type ModuleNameEnv elt = UniqFM elt + + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +-- Has deterministic folds and can be deterministically converted to a list +type DModuleNameEnv elt = UniqDFM elt diff --git a/compiler/GHC/Types/Module.hs-boot b/compiler/GHC/Types/Module.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Module.hs-boot @@ -0,0 +1,13 @@ +module GHC.Types.Module where + +import GhcPrelude + +data Module +data ModuleName +data UnitId +data InstalledUnitId +data ComponentId + +moduleName :: Module -> ModuleName +moduleUnitId :: Module -> UnitId +unitIdString :: UnitId -> String diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name.hs @@ -0,0 +1,693 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Name]{@Name@: to transmit name info from renamer to typechecker} +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They +-- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have +-- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names +-- also contain information about where they originated from, see "Name#name_sorts" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" +-- +-- #name_sorts# +-- Names are one of: +-- +-- * External, if they name things declared in other modules. Some external +-- Names are wired in, i.e. they name primitives defined in the compiler itself +-- +-- * Internal, if they name things in the module being compiled. Some internal +-- Names are system names, if they are names manufactured by the compiler + +module GHC.Types.Name ( + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, + mkFCallName, + mkExternalName, mkWiredInName, + + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameNameSpace, nameModule, nameModule_maybe, + setNameLoc, + tidyNameOcc, + localiseName, + + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, + isWiredInName, isWiredIn, isBuiltInSyntax, + isHoleName, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, nameIsHomePackage, + nameIsHomePackageImport, nameIsFromExternalPackage, + stableNameCmp, + + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, getOccFS, + + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, + nameStableString, + + -- Re-export the OccName stuff + module GHC.Types.Name.Occurrence + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) + +import GHC.Types.Name.Occurrence +import GHC.Types.Module +import GHC.Types.SrcLoc +import GHC.Types.Unique +import Util +import Maybes +import Binary +import FastString +import Outputable + +import Control.DeepSeq +import Data.Data + +{- +************************************************************************ +* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +* * +************************************************************************ +-} + +-- | A unique, unambiguous name for something, containing information about where +-- that thing originated. +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: {-# UNPACK #-} !Unique, + n_loc :: !SrcSpan -- Definition site + } + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +-- See Note [About the NameSorts] +data NameSort + = External Module + + | WiredIn Module TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +instance Outputable NameSort where + ppr (External _) = text "external" + ppr (WiredIn _ _ _) = text "wired-in" + ppr Internal = text "internal" + ppr System = text "system" + +instance NFData Name where + rnf Name{..} = rnf n_sort + +instance NFData NameSort where + rnf (External m) = rnf m + rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () + -- XXX this is a *lie*, we're not going to rnf the TyThing, but + -- since the TyThings for WiredIn Names are all static they can't + -- be hiding space leaks or errors. + rnf Internal = () + rnf System = () + +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- which have special syntactic forms. They aren't in scope +-- as such. +data BuiltInSyntax = BuiltInSyntax | UserSyntax + +{- +Note [About the NameSorts] + +1. Initially, top-level Ids (including locally-defined ones) get External names, + and all other local Ids get Internal names + +2. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in GHC.Iface.Env. + +3. Things with a External name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @External@ first. + +4. In the tidy-core phase, a External that is not visible to an importer + is changed to Internal, and a Internal that is visible is changed to External + +5. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) + +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others + +All built-in syntax is for wired-in things. +-} + +instance HasOccName Name where + occName = nameOccName + +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameNameSpace :: Name -> NameSpace +nameModule :: HasDebugCallStack => Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameNameSpace name = occNameSpace (n_occ name) +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name + +{- +************************************************************************ +* * +\subsection{Predicates on names} +* * +************************************************************************ +-} + +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName _ = False + +isWiredIn :: NamedThing thing => thing -> Bool +isWiredIn = isWiredInName . getName + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe _ = Nothing + +isBuiltInSyntax :: Name -> Bool +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax _ = False + +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName _ = False + +isInternalName name = not (isExternalName name) + +isHoleName :: Name -> Bool +isHoleName = isHoleModule . nameModule + +nameModule name = + nameModule_maybe name `orElse` + pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) + +nameModule_maybe :: Name -> Maybe Module +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe _ = Nothing + +nameIsLocalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is +-- (a) Internal +-- (b) External but from the specified module +-- (c) External but from the 'interactive' package +-- +-- The key idea is that +-- False means: the entity is defined in some other module +-- you can find the details (type, fixity, instances) +-- in some interface file +-- those details will be stored in the EPT or HPT +-- +-- True means: the entity is defined in this module or earlier in +-- the GHCi session +-- you can find details (type, fixity, instances) in the +-- TcGblEnv or TcLclEnv +-- +-- The isInteractiveModule part is because successive interactions of a GHCi session +-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come +-- from the magic 'interactive' package; and all the details are kept in the +-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. +-- See Note [The interactive package] in GHC.Driver.Types + +nameIsLocalOrFrom from name + | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod + | otherwise = True + +nameIsHomePackage :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +nameIsHomePackage this_mod + = \nm -> case n_sort nm of + External nm_mod -> moduleUnitId nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg + Internal -> True + System -> False + where + this_pkg = moduleUnitId this_mod + +nameIsHomePackageImport :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +-- /other than/ the this_mod +nameIsHomePackageImport this_mod + = \nm -> case nameModule_maybe nm of + Nothing -> False + Just nm_mod -> nm_mod /= this_mod + && moduleUnitId nm_mod == this_pkg + where + this_pkg = moduleUnitId this_mod + +-- | Returns True if the Name comes from some other package: neither this +-- package nor the interactive package. +nameIsFromExternalPackage :: UnitId -> Name -> Bool +nameIsFromExternalPackage this_pkg name + | Just mod <- nameModule_maybe name + , moduleUnitId mod /= this_pkg -- Not this package + , not (isInteractiveModule mod) -- Not the 'interactive' package + = True + | otherwise + = False + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + +isDataConName :: Name -> Bool +isDataConName name = isDataOcc (nameOccName name) + +isValName :: Name -> Bool +isValName name = isValOcc (nameOccName name) + +isVarName :: Name -> Bool +isVarName = isVarOcc . nameOccName + +isSystemName (Name {n_sort = System}) = True +isSystemName _ = False + +{- +************************************************************************ +* * +\subsection{Making names} +* * +************************************************************************ +-} + +-- | Create a name which is (for now at least) local to the current module and hence +-- does not need a 'Module' to disambiguate it from other 'Name's +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which makes + -- the OccNames distinct when they need to be + +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + +-- | Create a name which definitely originates in the given module +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache +mkExternalName uniq mod occ loc + = Name { n_uniq = uniq, n_sort = External mod, + n_occ = occ, n_loc = loc } + +-- | Create a name which is actually defined by the compiler itself +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } + +-- | Create a name brought into being by the compiler +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan + +mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name +mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System + , n_occ = occ, n_loc = loc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) + +-- | Make a name for a foreign call +mkFCallName :: Unique -> String -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan + -- The encoded string completely describes the ccall + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = uniq} + +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +-- | Make the 'Name' into an internal name, regardless of what it was to begin with +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } + +{- +************************************************************************ +* * +\subsection{Hashing and comparison} +* * +************************************************************************ +-} + +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 + +-- | Compare Names lexicographically +-- This only works for Names that originate in the source code or have been +-- tidied. +stableNameCmp :: Name -> Name -> Ordering +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicographic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT + +{- +************************************************************************ +* * +\subsection[Name-instances]{Instance declarations} +* * +************************************************************************ +-} + +-- | The same comments as for `Name`'s `Ord` instance apply. +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which +-- means that the ordering is not stable across deserialization or rebuilds. +-- +-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug +-- caused by improper use of this instance. + +-- For a deterministic lexicographic ordering, use `stableNameCmp`. +instance Ord Name where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" + +{- +************************************************************************ +* * +\subsection{Binary} +* * +************************************************************************ +-} + +-- | Assumes that the 'Name' is a non-binding one. See +-- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for +-- serializing binding 'Name's. See 'UserData' for the rationale for this +-- distinction. +instance Binary Name where + put_ bh name = + case getUserData bh of + UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name + + get bh = + case getUserData bh of + UserData { ud_get_name = get_name } -> get_name bh + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ + +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ + +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal sty uniq mod occ is_wired is_builtin + | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + | debugStyle sty = pp_mod <> ppr_occ_name occ + <> braces (hsep [if is_wired then text "(w)" else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax + | otherwise = + if isHoleModule mod + then case qualName sty mod occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod occ <> ppr_occ_name occ + where + pp_mod = ppUnlessOption sdocSuppressModulePrefixes + (ppr mod <> dot) + +pprInternal :: PprStyle -> Unique -> OccName -> SDoc +pprInternal sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem :: PprStyle -> Unique -> OccName -> SDoc +pprSystem sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + + +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in GHC.Driver.Types +pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ + case qualName sty mod occ of -- See Outputable.QualifyName: + NameQual modname -> ppr modname <> dot -- Name is in scope + NameNotInScope1 -> ppr mod <> dot -- Not in scope + NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in + <> ppr (moduleName mod) <> dot -- scope either + NameUnqual -> empty -- In scope unqualified + +pprUnique :: Unique -> SDoc +-- Print a unique unless we are suppressing them +pprUnique uniq + = ppUnlessOption sdocSuppressUniques $ + pprUniqueAlways uniq + +ppr_underscore_unique :: Unique -> SDoc +-- Print an underscore separating the name from its unique +-- But suppress it if we aren't printing the uniques anyway +ppr_underscore_unique uniq + = ppUnlessOption sdocSuppressUniques $ + char '_' <> pprUniqueAlways uniq + +ppr_occ_name :: OccName -> SDoc +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are +-- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprDefinedAt :: Name -> SDoc +pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name + +pprNameDefnLoc :: Name -> SDoc +-- Prints "at " or +-- or "in " depending on what info is available +pprNameDefnLoc name + = case nameSrcLoc name of + -- nameSrcLoc rather than nameSrcSpan + -- It seems less cluttered to show a location + -- rather than a span for the definition point + RealSrcLoc s _ -> text "at" <+> ppr s + UnhelpfulLoc s + | isInternalName name || isSystemName name + -> text "at" <+> ftext s + | otherwise + -> text "in" <+> quotes (ppr (nameModule name)) + + +-- | Get a string representation of a 'Name' that's unique and stable +-- across recompilations. Used for deterministic generation of binds for +-- derived instances. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" +nameStableString :: Name -> String +nameStableString Name{..} = + nameSortStableString n_sort ++ "$" ++ occNameString n_occ + +nameSortStableString :: NameSort -> String +nameSortStableString System = "$_sys" +nameSortStableString Internal = "$_in" +nameSortStableString (External mod) = moduleStableString mod +nameSortStableString (WiredIn mod _ _) = moduleStableString mod + +{- +************************************************************************ +* * +\subsection{Overloaded functions related to Names} +* * +************************************************************************ +-} + +-- | A class allowing convenient access to the 'Name' of various datatypes +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method + +instance NamedThing e => NamedThing (Located e) where + getName = getName . unLoc + +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String +getOccFS :: NamedThing a => a -> FastString + +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName +getOccFS = occNameFS . getOccName + +pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName :: NamedThing a => a -> SDoc +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name.hs-boot @@ -0,0 +1,5 @@ +module GHC.Types.Name where + +import GhcPrelude () + +data Name diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name/Cache.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | The Name Cache +module GHC.Types.Name.Cache + ( lookupOrigNameCache + , extendOrigNameCache + , extendNameCache + , initNameCache + , NameCache(..), OrigNameCache + ) where + +import GhcPrelude + +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Unique.Supply +import TysWiredIn +import Util +import Outputable +import PrelNames + +#include "HsVersions.h" + +{- + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invocation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower +their cost we use two tricks, + + a. We specially encode tuple and sum Names in interface files' symbol tables + to avoid having to look up their names while loading interface files. + Namely these names are encoded as by their Uniques. We know how to get from + a Unique back to the Name which it represents via the mapping defined in + the SumTupleUniques module. See Note [Symbol table representation of names] + in GHC.Iface.Binary and for details. + + b. We don't include them in the Orig name cache but instead parse their + OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with + them. + +Why is the second measure necessary? Good question; afterall, 1) the parser +emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never +needs to looked-up during interface loading due to (a). It turns out that there +are two reasons why we might look up an Orig RdrName for built-in syntax, + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName + (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will + go this route (#8954). + +-} + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + , Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in PrelNames + -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just name + + | otherwise + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name + +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache + = NameCache { nsUniqs :: !UniqSupply, + -- ^ Supply of uniques + nsNames :: !OrigNameCache + -- ^ Ensures that one original name gets one unique + } + +-- | Return a function to atomically update the name cache. +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name/Env.hs @@ -0,0 +1,175 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[NameEnv]{@NameEnv@: name environments} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Types.Name.Env ( + -- * Var, Id and TyVar environments (maps) + NameEnv, + + -- ** Manipulating these environments + mkNameEnv, mkNameEnvWith, + emptyNameEnv, isEmptyNameEnv, + unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, + extendNameEnvList, extendNameEnvList_C, + filterNameEnv, anyNameEnv, + plusNameEnv, plusNameEnv_C, alterNameEnv, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv, disjointNameEnv, + + DNameEnv, + + emptyDNameEnv, + lookupDNameEnv, + delFromDNameEnv, filterDNameEnv, + mapDNameEnv, + adjustDNameEnv, alterDNameEnv, extendDNameEnv, + -- ** Dependency analysis + depAnal + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Digraph +import GHC.Types.Name +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import Maybes + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +{- +Note [depAnal determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +depAnal is deterministic provided it gets the nodes in a deterministic order. +The order of lists that get_defs and get_uses return doesn't matter, as these +are only used to construct the edges, and stronglyConnCompFromEdgedVertices is +deterministic even when the edges are not in deterministic order as explained +in Note [Deterministic SCC] in Digraph. +-} + +depAnal :: forall node. + (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Perform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVerticesUniq graph_nodes + where + graph_nodes = (map mk_node keyed_nodes) :: [Node Int node] + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = + let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node)) + in DigraphNode node key edges + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +-- | Name Environment +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +isEmptyNameEnv :: NameEnv a -> Bool +mkNameEnv :: [(Name,a)] -> NameEnv a +mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 +disjointNameEnv :: NameEnv a -> NameEnv a -> Bool + +nameEnvElts x = eltsUFM x +emptyNameEnv = emptyUFM +isEmptyNameEnv = isNullUFM +unitNameEnv x y = unitUFM x y +extendNameEnv x y z = addToUFM x y z +extendNameEnvList x l = addListToUFM x l +lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM +mkNameEnv l = listToUFM l +mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) +elemNameEnv x y = elemUFM x y +plusNameEnv x y = plusUFM x y +plusNameEnv_C f x y = plusUFM_C f x y +extendNameEnv_C f x y z = addToUFM_C f x y z +mapNameEnv f x = mapUFM f x +extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendNameEnvList_C x y z = addListToUFM_C x y z +delFromNameEnv x y = delFromUFM x y +delListFromNameEnv x y = delListFromUFM x y +filterNameEnv x y = filterUFM x y +anyNameEnv f x = foldUFM ((||) . f) False x +disjointNameEnv x y = isNullUFM (intersectUFM x y) + +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) + +-- | Deterministic Name Environment +-- +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why +-- we need DNameEnv. +type DNameEnv a = UniqDFM a + +emptyDNameEnv :: DNameEnv a +emptyDNameEnv = emptyUDFM + +lookupDNameEnv :: DNameEnv a -> Name -> Maybe a +lookupDNameEnv = lookupUDFM + +delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a +delFromDNameEnv = delFromUDFM + +filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a +filterDNameEnv = filterUDFM + +mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b +mapDNameEnv = mapUDFM + +adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a +adjustDNameEnv = adjustUDFM + +alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a +alterDNameEnv = alterUDFM + +extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a +extendDNameEnv = addToUDFM diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -0,0 +1,927 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName' represents names as strings with just a little more information: +-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or +-- data constructors +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module GHC.Types.Name.Occurrence ( + -- * The 'NameSpace' type + NameSpace, -- Abstract + + nameSpacesRelated, + + -- ** Construction + -- $real_vs_source_data_constructors + tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, + + -- ** Pretty Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The 'OccName' type + OccName, -- Abstract, instance of Outputable + pprOccName, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkDataOcc, mkDataOccFS, + mkTyVarOcc, mkTyVarOccFS, + mkTcOcc, mkTcOccFS, + mkClsOcc, mkClsOccFS, + mkDFunOcc, + setOccNameSpace, + demoteOccName, + HasOccName(..), + + -- ** Derived 'OccName's + isDerivedOccName, + mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, + mkNewTyCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkSuperDictAuxOcc, + mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkRecFldSelOcc, + mkTyConRepOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, startsWithUnderscore, + + isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + + -- * The 'OccEnv' type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, + alterOccEnv, pprOccEnv, + + -- * The 'OccSet' type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, + isEmptyOccSet, intersectOccSet, intersectsOccSet, + filterOccSet, + + -- * Tidying up + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, + tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + ) where + +import GhcPrelude + +import Util +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import FastString +import FastStringEnv +import Outputable +import GHC.Utils.Lexeme +import Binary +import Control.DeepSeq +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsection{Name space} +* * +************************************************************************ +-} + +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in GHC.Core.DataCon +-- +-- $real_vs_source_data_constructors +-- There are two forms of data constructor: +-- +-- [Source data constructors] The data constructors mentioned in Haskell source code +-- +-- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type +-- +-- For example: +-- +-- > data T = T !(Int, Int) +-- +-- The source datacon has type @(Int, Int) -> T@ +-- The real datacon has type @Int -> Int -> T@ +-- +-- GHC chooses a representation based on the strictness etc. + +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +isDataConNameSpace :: NameSpace -> Bool +isDataConNameSpace DataName = True +isDataConNameSpace _ = False + +isTcClsNameSpace :: NameSpace -> Bool +isTcClsNameSpace TcClsName = True +isTcClsNameSpace _ = False + +isTvNameSpace :: NameSpace -> Bool +isTvNameSpace TvName = True +isTvNameSpace _ = False + +isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace _ = False + +isValNameSpace :: NameSpace -> Bool +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace _ = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" + +-- demoteNameSpace lowers the NameSpace if possible. We can not know +-- in advance, since a TvName can appear in an HsTyVar. +-- See Note [Demotion] in GHC.Rename.Env +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Nothing +demoteNameSpace TcClsName = Just DataName + +{- +************************************************************************ +* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +* * +************************************************************************ +-} + +-- | Occurrence Name +-- +-- In this context that means: +-- "classified (i.e. as a type name, value name, etc) but not qualified +-- and not yet resolved" +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) + = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id + +instance NFData OccName where + rnf x = x `seq` () + +{- +************************************************************************ +* * +\subsection{Printing} +* * +************************************************************************ +-} + +instance Outputable OccName where + ppr = pprOccName + +instance OutputableBndr OccName where + pprBndr _ = ppr + pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) + pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) + +pprOccName :: OccName -> SDoc +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS occ) + else pp_occ <> pp_debug sty + where + pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) + | otherwise = empty + + pp_occ = sdocOption sdocSuppressUniques $ \case + True -> text (strip_th_unique (unpackFS occ)) + False -> ftext occ + + -- See Note [Suppressing uniques in OccNames] + strip_th_unique ('[' : c : _) | isAlphaNum c = [] + strip_th_unique (c : cs) = c : strip_th_unique cs + strip_th_unique [] = [] + +{- +Note [Suppressing uniques in OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a hack to de-wobblify the OccNames that contain uniques from +Template Haskell that have been turned into a string in the OccName. +See Note [Unique OccNames from Template Haskell] in Convert.hs + +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkDataOcc :: String -> OccName +mkDataOcc = mkOccName dataName + +mkDataOccFS :: FastString -> OccName +mkDataOccFS = mkOccNameFS dataName + +mkTyVarOcc :: String -> OccName +mkTyVarOcc = mkOccName tvName + +mkTyVarOccFS :: FastString -> OccName +mkTyVarOccFS fs = mkOccNameFS tvName fs + +mkTcOcc :: String -> OccName +mkTcOcc = mkOccName tcName + +mkTcOccFS :: FastString -> OccName +mkTcOccFS = mkOccNameFS tcName + +mkClsOcc :: String -> OccName +mkClsOcc = mkOccName clsName + +mkClsOccFS :: FastString -> OccName +mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- see Note [Demotion] +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name + +-- Name spaces are related if there is a chance to mean the one when one writes +-- the other, i.e. variables <-> data constructors and type variables <-> type constructors +nameSpacesRelated :: NameSpace -> NameSpace -> Bool +nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 + +otherNameSpace :: NameSpace -> NameSpace +otherNameSpace VarName = DataName +otherNameSpace DataName = VarName +otherNameSpace TvName = TcClsName +otherNameSpace TcClsName = TvName + + + +{- | Other names in the compiler add additional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName + +{- +************************************************************************ +* * + Environments +* * +************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char representing the name space. This in turn makes it +easy to build an OccEnv. +-} + +instance Uniquable OccName where + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs + +newtype OccEnv a = A (UniqFM a) + deriving Data + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt +alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y +alterOccEnv fn (A y) k = A $ alterUFM fn y k + +instance Outputable a => Outputable (OccEnv a) where + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env + +type OccSet = UniqSet OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool +filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +filterOccSet = filterUniqSet + +{- +************************************************************************ +* * +\subsection{Predicates and taking them apart} +* * +************************************************************************ +-} + +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc _ = False + +isTvOcc (OccName TvName _) = True +isTvOcc _ = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc _ = False + +-- | /Value/ 'OccNames's are those that are either in +-- the variable or data constructor namespaces +isValOcc :: OccName -> Bool +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc _ = False + +isDataOcc (OccName DataName _) = True +isDataOcc _ = False + +-- | Test if the 'OccName' is a data constructor that starts with +-- a symbol (e.g. @:@, or @[]@) +isDataSymOcc :: OccName -> Bool +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc _ = False +-- Pretty inefficient! + +-- | Test if the 'OccName' is that for any operator (whether +-- it is a data constructor or variable or whatever) +isSymOcc :: OccName -> Bool +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName TvName s) = isLexSym s +-- Pretty inefficient! + +parenSymOcc :: OccName -> SDoc -> SDoc +-- ^ Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc + +startsWithUnderscore :: OccName -> Bool +-- ^ Haskell 98 encourages compilers to suppress warnings about unused +-- names in a pattern if they start with @_@: this implements that test +startsWithUnderscore occ = headFS (occNameFS occ) == '_' + +{- +************************************************************************ +* * +\subsection{Making system names} +* * +************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + +All of these other OccNames contain a mixture of alphabetic +and symbolic characters, and hence cannot possibly clash with +a user-written type or function name + + $f... Dict-fun identifiers (from inst decls) + $dmop Default method for 'op' + $pnC n'th superclass selector for class C + $wf Worker for function 'f' + $sf.. Specialised version of f + D:C Data constructor for dictionary for class C + NTCo:T Coercion connecting newtype T with its representation type + TFCo:R Coercion connecting a data family to its representation type R + +In encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! +-} + +-- | Build an 'OccName' derived from another 'OccName'. +-- +-- Note that the pieces of the name are passed in as a @[FastString]@ so that +-- the whole name can be constructed with a single 'concatFS', minimizing +-- unnecessary intermediate allocations. +mk_deriv :: NameSpace + -> FastString -- ^ A prefix which distinguishes one sort of + -- derived name from another + -> [FastString] -- ^ The name we are deriving from in pieces which + -- will be concatenated. + -> OccName +mk_deriv occ_sp sys_prefix str = + mkOccNameFS occ_sp (concatFS $ sys_prefix : str) + +isDerivedOccName :: OccName -> Bool +-- ^ Test for definitions internally generated by GHC. This predicate +-- is used to suppress printing of internal definitions in some debug prints +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo + c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions + _other -> False + +isDefaultMethodOcc :: OccName -> Bool +isDefaultMethodOcc occ = + case occNameString occ of + '$':'d':'m':_ -> True + _ -> False + +-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? +-- This is needed as these bindings are renamed differently. +-- See Note [Grand plan for Typeable] in TcTypeable. +isTypeableBindOcc :: OccName -> Bool +isTypeableBindOcc occ = + case occNameString occ of + '$':'t':'c':_ -> True -- mkTyConRepOcc + '$':'t':'r':_ -> True -- Module binding + _ -> False + +mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkTyConRepOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" +mkBuilderOcc = mk_simple_deriv varName "$b" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" +mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible +mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class +mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" + +-- Used in derived instances +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" + +-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable +mkTyConRepOcc occ = mk_simple_deriv varName prefix occ + where + prefix | isDataOcc occ = "$tc'" + | otherwise = "$tc" + +-- Generic deriving mechanism +mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" + +-- Overloaded record field selectors +mkRecFldSelOcc :: String -> OccName +mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] + +mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName +mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ + +mkSuperDictAuxOcc :: Int -> OccName -> OccName +mkSuperDictAuxOcc index cls_tc_occ + = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] + +mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 + -> OccName -- ^ Class, e.g. @Ord@ + -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] + +mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' + -> OccName -- ^ Local name, e.g. @sat@ + -> OccName -- ^ Nice unique version, e.g. @$L23sat@ +mkLocalOcc uniq occ + = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) + +-- | Derive a name for the representation type constructor of a +-- @data@\/@newtype@ instance. +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) + +mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. + -- Only used in debug mode, for extra clarity + -> Bool -- ^ Is this a hs-boot instance DFun? + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set + where + prefix | is_boot = "$fx" + | otherwise = "$f" + +mkDataTOcc, mkDataCOcc + :: OccName -- ^ TyCon or data con string + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ +-- data T = MkT ... deriving( Data ) needs definitions for +-- $tT :: Data.Generics.Basics.DataType +-- $cMkT :: Data.Generics.Basics.Constr +mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) +mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) + +{- +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. +-} + +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ + +{- +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See TcClassDcl.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. +-} + +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ + +{- +************************************************************************ +* * +\subsection{Tidying them up} +* * +************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +Note [TidyOccEnv] +~~~~~~~~~~~~~~~~~ +type TidyOccEnv = UniqFM Int + +* Domain = The OccName's FastString. These FastStrings are "taken"; + make sure that we don't re-use + +* Int, n = A plausible starting point for new guesses + There is no guarantee that "FSn" is available; + you must look that up in the TidyOccEnv. But + it's a good place to start looking. + +* When looking for a renaming for "foo2" we strip off the "2" and start + with "foo". Otherwise if we tidy twice we get silly names like foo23. + + However, if it started with digits at the end, we always make a name + with digits at the end, rather than shortening "foo2" to just "foo", + even if "foo" is unused. Reasons: + - Plain "foo" might be used later + - We use trailing digits to subtly indicate a unification variable + in typechecker error message; see TypeRep.tidyTyVarBndr + +We have to take care though! Consider a machine-generated module (#10370) + module Foo where + a1 = e1 + a2 = e2 + ... + a2000 = e2000 +Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, +we have to do a linear search to find a free one, "a2001". That might just be +acceptable once. But if we now come across "a8" again, we don't want to repeat +that search. + +So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for +starting the search; and we make sure to update the starting point for "a" +after we allocate a new one. + + +Note [Tidying multiple names at once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider + + > :t (id,id,id) + +Every id contributes a type variable to the type signature, and all of them are +"a". If we tidy them one by one, we get + + (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) + +which is a bit unfortunate, as it unfairly renames only two of them. What we +would like to see is + + (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) + +To achieve this, the function avoidClashesOccEnv can be used to prepare the +TidyEnv, by “blocking” every name that occurs twice in the map. This way, none +of the "a"s will get the privilege of keeping this name, and all of them will +get a suitable number by tidyOccName. + +This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs +for an example where this is used. + +This is #12382. + +-} + +type TidyOccEnv = UniqFM Int -- The in-scope OccNames + -- See Note [TidyOccEnv] + +emptyTidyOccEnv :: TidyOccEnv +emptyTidyOccEnv = emptyUFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl' add emptyUFM + where + add env (OccName _ fs) = addToUFM env fs 1 + +delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv +delTidyOccEnvList = delListFromUFM + +-- see Note [Tidying multiple names at once] +avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +avoidClashesOccEnv env occs = go env emptyUFM occs + where + go env _ [] = env + go env seenOnce ((OccName _ fs):occs) + | fs `elemUFM` env = go env seenOnce occs + | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs + | otherwise = go env (addToUFM seenOnce fs ()) occs + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) +tidyOccName env occ@(OccName occ_sp fs) + | not (fs `elemUFM` env) + = -- Desired OccName is free, so use it, + -- and record in 'env' that it's no longer available + (addToUFM env fs 1, occ) + + | otherwise + = case lookupUFM env base1 of + Nothing -> (addToUFM env base1 2, OccName occ_sp base1) + Just n -> find 1 n + where + base :: String -- Drop trailing digits (see Note [TidyOccEnv]) + base = dropWhileEndLE isDigit (unpackFS fs) + base1 = mkFastString (base ++ "1") + + find !k !n + = case lookupUFM env new_fs of + Just {} -> find (k+1 :: Int) (n+k) + -- By using n+k, the n argument to find goes + -- 1, add 1, add 2, add 3, etc which + -- moves at quadratic speed through a dense patch + + Nothing -> (new_env, OccName occ_sp new_fs) + where + new_fs = mkFastString (base ++ show n) + new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) + -- Update: base1, so that next time we'll start where we left off + -- new_fs, so that we know it is taken + -- If they are the same (n==1), the former wins + -- See Note [TidyOccEnv] + + +{- +************************************************************************ +* * + Binary instance + Here rather than in GHC.Iface.Binary because OccName is abstract +* * +************************************************************************ +-} + +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) diff --git a/compiler/GHC/Types/Name/Occurrence.hs-boot b/compiler/GHC/Types/Name/Occurrence.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name/Occurrence.hs-boot @@ -0,0 +1,5 @@ +module GHC.Types.Name.Occurrence where + +import GhcPrelude () + +data OccName diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name/Reader.hs @@ -0,0 +1,1387 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'OccName.OccName' with an optional module +-- qualifier +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module GHC.Types.Name.Reader ( + -- * The main type + RdrName(..), -- Constructors exported only to GHC.Iface.Binary + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + rdrNameOcc, rdrNameSpace, demoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, delLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, + lookupGRE_Name_OccName, + getGRE_NameQualifier_maybes, + transformGREs, pickGREs, pickGREsModExp, + + -- * GlobalRdrElts + gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, + greRdrNames, greSrcSpan, greQualModName, + gresToAvailInfo, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel, + unQualOK, qualSpecOK, unQualSpecOK, + pprNameProvenance, + Parent(..), greParent_maybe, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, isExplicitItem, bestImport, + + -- * Utils for StarIsType + starInfo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Set +import Maybes +import GHC.Types.SrcLoc as SrcLoc +import FastString +import GHC.Types.FieldLabel +import Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import Util +import GHC.Types.Name.Env + +import Data.Data +import Data.List( sortBy ) + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, +-- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, +-- 'ApiAnnotation.AnnBackquote' @'`'@, +-- 'ApiAnnotation.AnnVal' +-- 'ApiAnnotation.AnnTilde', + +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +-- demoteRdrName lowers the NameSpace of RdrName. +-- see Note [Demotion] in GHC.Types.Name.Occurrence +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = panic "demoteRdrName" +demoteRdrName (Exact _) = panic "demoteRdrName" + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +-- | Local Reader Environment +-- +-- This environment is used to store local bindings +-- (@let@, @where@, lambda, @case@). +-- It is keyed by OccName, because we never use it for qualified names +-- We keep the current mapping, *and* the set of all Names in scope +-- Reason: see Note [Splicing Exact names] in GHC.Rename.Env +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" + <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) + ] <+> char '}') + where + ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv + , lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- The Name should be a non-top-level thing +extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name + = WARN( isExternalName name, ppr name ) + lre { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names + = WARN( any isExternalName names, ppr names ) + lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr + | Unqual occ <- rdr + = lookupOccEnv env occ + + -- See Note [Local bindings with Exact Names] + | Exact name <- rdr + , name `elemNameSet` ns + = Just name + + | otherwise + = Nothing + +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +delLocalRdrEnvList lre@(LRE { lre_env = env }) occs + = lre { lre_env = delListFromOccEnv env occs } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in GHC.Rename.Types.bindHsQTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +-- | Global Reader Environment +type GlobalRdrEnv = OccEnv [GlobalRdrElt] +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT 1: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT 2: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in GHC.Rename.Names +-- Note [Top-level Names in Template Haskell decl quotes] +-- +-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then +-- greOccName gre = occ +-- +-- NB: greOccName gre is usually the same as +-- nameOccName (gre_name gre), but not always in the +-- case of record selectors; see greOccName + +-- | Global Reader Element +-- +-- An element of the 'GlobalRdrEnv' +data GlobalRdrElt + = GRE { gre_name :: Name + , gre_par :: Parent + , gre_lcl :: Bool -- ^ True <=> the thing was defined locally + , gre_imp :: [ImportSpec] -- ^ In scope through these imports + } deriving (Data, Eq) + -- INVARIANT: either gre_lcl = True or gre_imp is non-empty + -- See Note [GlobalRdrElt provenance] + +-- | The children of a Name are the things that are abbreviated by the ".." +-- notation in export lists. See Note [Parents] +data Parent = NoParent + | ParentIs { par_is :: Name } + | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } + -- ^ See Note [Parents for record fields] + deriving (Eq, Data) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = text "parent:" <> ppr n + ppr (FldParent n f) = text "fldparent:" + <> ppr n <> colon <> ppr f + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent p1@(ParentIs _) p2 = hasParent p1 p2 +plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 +plusParent p1 p2@(ParentIs _) = hasParent p2 p1 +plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 +plusParent _ _ = NoParent + +hasParent :: Parent -> Parent -> Parent +#if defined(DEBUG) +hasParent p NoParent = p +hasParent p p' + | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree +#endif +hasParent p _ = p + + +{- Note [GlobalRdrElt provenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", +i.e. how the Name came to be in scope. It can be in scope two ways: + - gre_lcl = True: it is bound in this module + - gre_imp: a list of all the imports that brought it into scope + +It's an INVARIANT that you have one or the other; that is, either +gre_lcl is True, or gre_imp is non-empty. + +It is just possible to have *both* if there is a module loop: a Name +is defined locally in A, and also brought into scope by importing a +module that SOURCE-imported A. Example (#7672): + + A.hs-boot module A where + data T + + B.hs module B(Decl.T) where + import {-# SOURCE #-} qualified A as Decl + + A.hs module A where + import qualified B + data T = Z | S B.T + +In A.hs, 'T' is locally bound, *and* imported as B.T. + +Note [Parents] +~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning + ~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Can not be bundled with a type constructor. + ParentIs n Can be bundled with the type constructor corresponding to + n. + FldParent See Note [Parents for record fields] + + + + +Note [Parents for record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record fields, in addition to the Name of the type constructor +(stored in par_is), we use FldParent to store the field label. This +extra information is used for identifying overloaded record fields +during renaming. + +In a definition arising from a normal module (without +-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the +field's label is the same as the OccName of the selector's Name. The +GlobalRdrEnv will contain an entry like this: + + "x" |-> GRE x (FldParent T Nothing) LocalDef + +When -XDuplicateRecordFields is enabled for the module that contains +T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel). +Thus we store the actual field label in par_lbl, and the GlobalRdrEnv +entry looks like this: + + "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef + +Note that the OccName used when adding a GRE to the environment +(greOccName) now depends on the parent field: for FldParent it is the +field label, if present, rather than the selector name. + +~~ + +Record pattern synonym selectors are treated differently. Their parent +information is `NoParent` in the module in which they are defined. This is because +a pattern synonym `P` has no parent constructor either. + +However, if `f` is bundled with a type constructor `T` then whenever `f` is +imported the parent will use the `Parent` constructor so the parent of `f` is +now `T`. + + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and then combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- Provenance (useful for "hiding" imports, or imports with no details). +gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +-- prov = Nothing => locally bound +-- Just spec => imported as described by spec +gresFromAvails prov avails + = concatMap (gresFromAvail (const prov)) avails + +localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] +-- Turn an Avail into a list of LocalDef GlobalRdrElts +localGREsFromAvail = gresFromAvail (const Nothing) + +gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] +gresFromAvail prov_fn avail + = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) + where + mk_gre n + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = [is] } + + mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = n }) + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = False, gre_imp = [is] } + where + mb_lbl | is_overloaded = Just lbl + | otherwise = Nothing + + +greQualModName :: GlobalRdrElt -> ModuleName +-- Get a suitable module qualifier for the GRE +-- (used in mkPrintUnqualified) +-- Prerecondition: the gre_name is always External +greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- nameModule_maybe name = moduleName mod + | (is:_) <- iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) + +greRdrNames :: GlobalRdrElt -> [RdrName] +greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } + = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) + where + occ = greOccName gre + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) + | lcl = nameSrcSpan name + | (is:_) <- iss = is_dloc (is_decl is) + | otherwise = pprPanic "greSrcSpan" (ppr gre) + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _ _) | n == m = NoParent + | otherwise = ParentIs m + +greParent_maybe :: GlobalRdrElt -> Maybe Name +greParent_maybe gre = case gre_par gre of + NoParent -> Nothing + ParentIs n -> Just n + FldParent n _ -> Just n + +-- | Takes a list of distinct GREs and folds them +-- into AvailInfos. This is more efficient than mapping each individual +-- GRE to an AvailInfo and the folding using `plusAvail` but needs the +-- uniqueness assumption. +gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] +gresToAvailInfo gres + = nameEnvElts avail_env + where + avail_env :: NameEnv AvailInfo -- Keyed by the parent + (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres + + add :: (NameEnv AvailInfo, NameSet) + -> GlobalRdrElt + -> (NameEnv AvailInfo, NameSet) + add (env, done) gre + | name `elemNameSet` done + = (env, done) -- Don't insert twice into the AvailInfo + | otherwise + = ( extendNameEnv_Acc comb availFromGRE env key gre + , done `extendNameSet` name ) + where + name = gre_name gre + key = case greParent_maybe gre of + Just parent -> parent + Nothing -> gre_name gre + + -- We want to insert the child `k` into a list of children but + -- need to maintain the invariant that the parent is first. + -- + -- We also use the invariant that `k` is not already in `ns`. + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren _ [] k = [k] + insertChildIntoChildren p (n:ns) k + | p == k = k:n:ns + | otherwise = n:k:ns + + comb :: GlobalRdrElt -> AvailInfo -> AvailInfo + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns fls) + = case gre_par gre of + NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls + FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) + +availFromGRE :: GlobalRdrElt -> AvailInfo +availFromGRE (GRE { gre_name = me, gre_par = parent }) + = case parent of + ParentIs p -> AvailTC p [me] [] + NoParent | isTyConName me -> AvailTC me [me] [] + | otherwise -> avail me + FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] + +mkFieldLabel :: Name -> Maybe FastString -> FieldLabel +mkFieldLabel me mb_lbl = + case mb_lbl of + Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) + , flIsOverloaded = False + , flSelector = me } + Just lbl -> FieldLabel { flLabel = lbl + , flIsOverloaded = True + , flSelector = me } + +emptyGlobalRdrEnv :: GlobalRdrEnv +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +instance Outputable GlobalRdrElt where + ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres = hang (ppr occ + <+> parens (text "unique" <+> ppr (getUnique occ)) + <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (gre_name (head gres)) + +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of + Nothing -> [] + Just gres -> gres + +greOccName :: GlobalRdrElt -> OccName +greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl +greOccName gre = nameOccName (gre_name gre) + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres + +lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment. This tests +-- whether it is in scope, ignoring anything else that might be in +-- scope with the same 'OccName'. +lookupGRE_Name env name + = lookupGRE_Name_OccName env name (nameOccName name) + +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt +-- ^ Look for a particular record field selector in the environment, where the +-- selector name and field label may be different: the GlobalRdrEnv is keyed on +-- the label. See Note [Parents for record fields] for why this happens. +lookupGRE_FieldLabel env fl + = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) + +lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' +-- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and +-- Note [Parents for record fields]. +lookupGRE_Name_OccName env name occ + = case [ gre | gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] of + [] -> Nothing + [gre] -> Just gre + gres -> pprPanic "lookupGRE_Name_OccName" + (ppr name $$ ppr occ $$ ppr gres) + -- See INVARIANT 1 on GlobalRdrEnv + + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env name + = case lookupGRE_Name env name of + Just gre -> [qualifier_maybe gre] + Nothing -> [] + where + qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl = Nothing + | otherwise = Just $ map (is_as . is_decl) iss + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_lcl = lcl }) = lcl + +isRecFldGRE :: GlobalRdrElt -> Bool +isRecFldGRE (GRE {gre_par = FldParent{}}) = True +isRecFldGRE _ = False + +-- Returns the field label of this GRE, if it has one +greLabel :: GlobalRdrElt -> Maybe FieldLabelString +greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl +greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) +greLabel _ = Nothing + +unQualOK :: GlobalRdrElt -> Bool +-- ^ Test if an unqualified version of this thing would be in scope +unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) + | lcl = True + | otherwise = any unQualSpecOK iss + +{- Note [GRE filtering] +~~~~~~~~~~~~~~~~~~~~~~~ +(pickGREs rdr gres) takes a list of GREs which have the same OccName +as 'rdr', say "x". It does two things: + +(a) filters the GREs to a subset that are in scope + * Qualified, as 'M.x' if want_qual is Qual M _ + * Unqualified, as 'x' if want_unqual is Unqual _ + +(b) for that subset, filter the provenance field (gre_lcl and gre_imp) + to ones that brought it into scope qualified or unqualified resp. + +Example: + module A ( f ) where + import qualified Foo( f ) + import Baz( f ) + f = undefined + +Let's suppose that Foo.f and Baz.f are the same entity really, but the local +'f' is different, so there will be two GREs matching "f": + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] + +The use of "f" in the export list is ambiguous because it's in scope +from the local def and the import Baz(f); but *not* the import qualified Foo. +pickGREs returns two GRE + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Bar ] + +Now the "ambiguous occurrence" message can correctly report how the +ambiguity arises. +-} + +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- ^ Takes a list of GREs which have the right OccName 'x' +-- Pick those GREs that are in scope +-- * Qualified, as 'M.x' if want_qual is Qual M _ +-- * Unqualified, as 'x' if want_unqual is Unqual _ +-- +-- Return each such GRE, with its ImportSpecs filtered, to reflect +-- how it is in scope qualified or unqualified respectively. +-- See Note [GRE filtering] +pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres +pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres +pickGREs _ _ = [] -- I don't think this actually happens + +pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt +pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl, null iss' = Nothing + | otherwise = Just (gre { gre_imp = iss' }) + where + iss' = filter unQualSpecOK iss + +pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt +pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) + | not lcl', null iss' = Nothing + | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) + where + iss' = filter (qualSpecOK mod) iss + lcl' = lcl && name_is_from mod n + + name_is_from :: ModuleName -> Name -> Bool + name_is_from mod name = case nameModule_maybe name of + Just n_mod -> moduleName n_mod == mod + Nothing -> False + +pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] +-- ^ Pick GREs that are in scope *both* qualified *and* unqualified +-- Return each GRE that is, as a pair +-- (qual_gre, unqual_gre) +-- These two GREs are the original GRE with imports filtered to express how +-- it is in scope qualified an unqualified respectively +-- +-- Used only for the 'module M' item in export list; +-- see GHC.Rename.Names.exports_from_avail +pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres + +pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) +pickBothGRE mod gre@(GRE { gre_name = n }) + | isBuiltInSyntax n = Nothing + | Just gre1 <- pickQualGRE mod gre + , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) + | otherwise = Nothing + where + -- isBuiltInSyntax filter out names for built-in syntax They + -- just clutter up the environment (esp tuples), and the + -- parser will generate Exact RdrNames for them, so the + -- cluttered envt is no use. Really, it's only useful for + -- GHC.Base and GHC.Tuple. + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE singleton env + (greOccName gre) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1 + , gre_lcl = gre_lcl g1 || gre_lcl g2 + , gre_imp = gre_imp g1 ++ gre_imp g2 + , gre_par = gre_par g1 `plusParent` gre_par g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre + = extendOccEnv_Acc insertGRE singleton env + (greOccName gre) gre + +shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv +shadowNames = foldl' shadowName + +{- Note [GlobalRdrEnv shadowing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before adding new names to the GlobalRdrEnv we nuke some existing entries; +this is "shadowing". The actual work is done by RdrEnv.shadowName. +Suppose + env' = shadowName env M.f + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + That is, shadowName does /not/ delete earlier qualified bindings + +There are two reasons for shadowing: + +* The GHCi REPL + + - Ids bought into scope on the command line (eg let x = True) have + External Names, like Ghci4.x. We want a new binding for 'x' (say) + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `mk_fake-imp_spec` in `shadowName`. See also Note + [Interactively-bound Ids in GHCi] in GHC.Driver.Types + + - Data types also have External Names, like Ghci4.T; but we still want + 'T' to mean the newly-declared 'T', not an old one. + +* Nested Template Haskell declaration brackets + See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + + Consider a TH decl quote: + module M where + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: + + - This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. + + - The External Name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + - We only shadow *External* names (which come from the main module), + or from earlier GHCi commands. Do not shadow *Internal* names + because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + At that stage, the class op 'f' will have an Internal name. +-} + +shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv +-- Remove certain old GREs that share the same OccName as this new Name. +-- See Note [GlobalRdrEnv shadowing] for details +shadowName env name + = alterOccEnv (fmap alter_fn) env (nameOccName name) + where + alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] + alter_fn gres = mapMaybe (shadow_with name) gres + + shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt + shadow_with new_name + old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) + = case nameModule_maybe old_name of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | Just new_mod <- nameModule_maybe new_name + , new_mod == old_mod -- Old name same as new name; shadow completely + -> Nothing + + | null iss' -- Nothing remains + -> Nothing + + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss + lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] + | otherwise = [] + + mk_fake_imp_spec old_name old_mod -- Urgh! + = ImpSpec id_spec ImpAll + where + old_mod_name = moduleName old_mod + id_spec = ImpDeclSpec { is_mod = old_mod_name + , is_as = old_mod_name + , is_qual = True + , is_dloc = nameSrcSpan old_name } + + shadow_is :: Name -> ImportSpec -> Maybe ImportSpec + shadow_is new_name is@(ImpSpec { is_decl = id_spec }) + | Just new_mod <- nameModule_maybe new_name + , is_as id_spec == moduleName new_mod + = Nothing -- Shadow both qualified and unqualified + | otherwise -- Shadow unqualified only + = Just (is { is_decl = id_spec { is_qual = True } }) + + +{- +************************************************************************ +* * + ImportSpec +* * +************************************************************************ +-} + +-- | Import Specification +-- +-- The 'ImportSpec' of something says how it came to be imported +-- It's quite elaborate so that we can give accurate unused-name warnings. +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Data ) + +-- | Import Declaration Specification +-- +-- Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- TODO: either should be Module, or there + -- should be a Maybe UnitId here too. + is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: Bool, -- ^ Was this import qualified? + is_dloc :: SrcSpan -- ^ The location of the entire import declaration + } deriving (Eq, Data) + +-- | Import Item Specification +-- +-- Describes import info a particular Name +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + deriving (Eq, Data) + +bestImport :: [ImportSpec] -> ImportSpec +-- See Note [Choosing the best import declaration] +bestImport iss + = case sortBy best iss of + (is:_) -> is + [] -> pprPanic "bestImport" (ppr iss) + where + best :: ImportSpec -> ImportSpec -> Ordering + -- Less means better + -- Unqualified always wins over qualified; then + -- import-all wins over import-some; then + -- earlier declaration wins over later + best (ImpSpec { is_item = item1, is_decl = d1 }) + (ImpSpec { is_item = item2, is_decl = d2 }) + = (is_qual d1 `compare` is_qual d2) `thenCmp` + (best_item item1 item2) `thenCmp` + SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) + + best_item :: ImpItemSpec -> ImpItemSpec -> Ordering + best_item ImpAll ImpAll = EQ + best_item ImpAll (ImpSome {}) = LT + best_item (ImpSome {}) ImpAll = GT + best_item (ImpSome { is_explicit = e1 }) + (ImpSome { is_explicit = e2 }) = e1 `compare` e2 + -- False < True, so if e1 is explicit and e2 is not, we get GT + +{- Note [Choosing the best import declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reporting unused import declarations we use the following rules. + (see [wiki:commentary/compiler/unused-imports]) + +Say that an import-item is either + * an entire import-all decl (eg import Foo), or + * a particular item in an import list (eg import Foo( ..., x, ...)). +The general idea is that for each /occurrence/ of an imported name, we will +attribute that use to one import-item. Once we have processed all the +occurrences, any import items with no uses attributed to them are unused, +and are warned about. More precisely: + +1. For every RdrName in the program text, find its GlobalRdrElt. + +2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one + the "chosen import-item", and mark it "used". This is done + by 'bestImport' + +3. After processing all the RdrNames, bleat about any + import-items that are unused. + This is done in GHC.Rename.Names.warnUnusedImportDecls. + +The function 'bestImport' returns the dominant import among the +ImportSpecs it is given, implementing Step 2. We say import-item A +dominates import-item B if we choose A over B. In general, we try to +choose the import that is most likely to render other imports +unnecessary. Here is the dominance relationship we choose: + + a) import Foo dominates import qualified Foo. + + b) import Foo dominates import Foo(x). + + c) Otherwise choose the textually first one. + +Rationale for (a). Consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + x + +The unqualified 'x' can only come from import #2. The qualified 'M.x' +could come from either, but bestImport picks import #2, because it is +more likely to be useful in other imports, as indeed it is in this +case (see #5211 for a concrete example). + +But the rules are not perfect; consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + M.y + +The M.x will use import #2, but M.y can only use import #1. +-} + + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> ModuleName +importSpecModule is = is_mod (is_decl is) + +isExplicitItem :: ImpItemSpec -> Bool +isExplicitItem ImpAll = False +isExplicitItem (ImpSome {is_explicit = exp}) = exp + +pprNameProvenance :: GlobalRdrElt -> SDoc +-- ^ Print out one place where the name was define/imported +-- (With -dppr-debug, print them all) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + = ifPprDebug (vcat pp_provs) + (head pp_provs) + where + pp_provs = pp_lcl ++ map pp_is iss + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] + else [] + pp_is is = sep [ppr is, ppr_defn_site is name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (text "and originally defined" <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = text "in" <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + ppr imp_spec + = text "imported" <+> qual + <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) + <+> pprLoc (importSpecLoc imp_spec) + where + qual | is_qual (is_decl imp_spec) = text "qualified" + | otherwise = empty + +pprLoc :: SrcSpan -> SDoc +pprLoc (RealSrcSpan s _) = text "at" <+> ppr s +pprLoc (UnhelpfulSpan {}) = empty + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that he's working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'starInfo' generates an appropriate hint to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, the resulting SDoc will contain a helpful suggestion. +-- Otherwise it is empty. +-- +starInfo :: Bool -> RdrName -> SDoc +starInfo star_is_type rdr_name = + -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to + -- take star_is_type as input? Why not refactor? + -- + -- The reason is that `sdocOption sdocStarIsType` would indicate that + -- StarIsType is enabled in the module that tries to load the problematic + -- definition, not in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + if isUnqualStar && not star_is_type + then text "With NoStarIsType, " <> + quotes (ppr rdr_name) <> + text " is treated as a regular type operator. " + $$ + text "Did you mean to use " <> quotes (text "Type") <> + text " from Data.Kind instead?" + else empty + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/compiler/GHC/Types/Name/Set.hs b/compiler/GHC/Types/Name/Set.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Name/Set.hs @@ -0,0 +1,215 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +-} + +{-# LANGUAGE CPP #-} +module GHC.Types.Name.Set ( + -- * Names set type + NameSet, + + -- ** Manipulating these sets + emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, + minusNameSet, elemNameSet, extendNameSet, extendNameSetList, + delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, + intersectsNameSet, intersectNameSet, + nameSetAny, nameSetAll, nameSetElemsStable, + + -- * Free variables + FreeVars, + + -- ** Manipulating sets of free variables + isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + intersectFVs, + + -- * Defs and uses + Defs, Uses, DefUse, DefUses, + + -- ** Manipulating defs and uses + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Name +import OrdList +import GHC.Types.Unique.Set +import Data.List (sortBy) + +{- +************************************************************************ +* * +\subsection[Sets of names} +* * +************************************************************************ +-} + +type NameSet = UniqSet Name + +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +extendNameSetList :: NameSet -> [Name] -> NameSet +extendNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSet :: NameSet -> NameSet -> NameSet +unionNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +extendNameSetList = addListToUniqSet +extendNameSet = addOneToUniqSet +unionNameSet = unionUniqSets +unionNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +delFromNameSet = delOneFromUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets + +delListFromNameSet set ns = foldl' delFromNameSet set ns + +intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) + +nameSetAny :: (Name -> Bool) -> NameSet -> Bool +nameSetAny = uniqSetAny + +nameSetAll :: (Name -> Bool) -> NameSet -> Bool +nameSetAll = uniqSetAll + +-- | Get the elements of a NameSet with some stable ordering. +-- This only works for Names that originate in the source code or have been +-- tidied. +-- See Note [Deterministic UniqFM] to learn about nondeterminism +nameSetElemsStable :: NameSet -> [Name] +nameSetElemsStable ns = + sortBy stableNameCmp $ nonDetEltsUniqSet ns + -- It's OK to use nonDetEltsUniqSet here because we immediately sort + -- with stableNameCmp + +{- +************************************************************************ +* * +\subsection{Free variables} +* * +************************************************************************ + +These synonyms are useful when we are thinking of free variables +-} + +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars +intersectFVs :: FreeVars -> FreeVars -> FreeVars + +isEmptyFVs :: NameSet -> Bool +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionNameSets +plusFV = unionNameSet +mkFVs = mkNameSet +addOneFV = extendNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +intersectFVs = intersectNameSet + +{- +************************************************************************ +* * + Defs and uses +* * +************************************************************************ +-} + +-- | A set of names that are defined somewhere +type Defs = NameSet + +-- | A set of names that are used somewhere +type Uses = NameSet + +-- | @(Just ds, us) =>@ The use of any member of the @ds@ +-- implies that all the @us@ are used too. +-- Also, @us@ may mention @ds@. +-- +-- @Nothing =>@ Nothing is defined in this group, but +-- nevertheless all the uses are essential. +-- Used for instance declarations, for example +type DefUse = (Maybe Defs, Uses) + +-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses +type DefUses = OrdList DefUse + +emptyDUs :: DefUses +emptyDUs = nilOL + +usesOnly :: Uses -> DefUses +usesOnly uses = unitOL (Nothing, uses) + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = appOL + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, _u1) d2 = d2 + get (Just d1, _u1) d2 = d1 `unionNameSet` d2 + +allUses :: DefUses -> Uses +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned +allUses dus = foldr get emptyNameSet dus + where + get (_d1, u1) u2 = u1 `unionNameSet` u2 + +duUses :: DefUses -> Uses +-- ^ Collect all 'Uses', regardless of whether the group is itself used, +-- but remove 'Defs' on the way +duUses dus = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. +-- The result is a superset of the input 'Uses'; and includes things defined +-- in the input 'DefUses' (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || nameSetAny (startsWithUnderscore . nameOccName) defs + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSet` uses + | otherwise -- No def is used + = uses diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -25,14 +25,14 @@ import GhcPrelude -import BasicTypes (Arity, RepArity) -import DataCon +import GHC.Types.Basic (Arity, RepArity) +import GHC.Core.DataCon import Outputable import PrelNames -import Coercion -import TyCon -import TyCoRep -import Type +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type import Util import TysPrim import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind ) diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/SrcLoc.hs @@ -0,0 +1,741 @@ +-- (c) The University of Glasgow, 1992-2006 + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + + +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations +module GHC.Types.SrcLoc ( + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), + + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + advanceSrcLoc, + advanceBufPos, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + interactiveSrcSpan, + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + srcSpanFirstCharacter, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + pprUserRealSpan, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, + containsSpan, + + -- * StringBuffer locations + BufPos(..), + BufSpan(..), + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + unRealSrcSpan, getRealSrcSpan, + + -- ** Modifying Located + mapLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost_smallest, + spans, isSubspanOf, isRealSubspanOf, sortLocated, + sortRealLocated, + lookupSrcLoc, lookupSrcSpan, + + liftL, + + -- * Parser locations + PsLoc(..), + PsSpan(..), + PsLocated, + advancePsLoc, + mkPsSpan, + psSpanStart, + psSpanEnd, + mkSrcSpanPs, + + ) where + +import GhcPrelude + +import Util +import Json +import Outputable +import FastString + +import Control.DeepSeq +import Control.Applicative (liftA2) +import Data.Bits +import Data.Data +import Data.List (sortBy, intercalate) +import Data.Function (on) +import qualified Data.Map as Map + +{- +************************************************************************ +* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +* * +************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +-} + +-- | Real Source Location +-- +-- Represents a single point within a file +data RealSrcLoc + = SrcLoc FastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 + deriving (Eq, Ord) + +-- | 0-based index identifying the raw location in the StringBuffer. +-- +-- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-} +-- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in +-- Lexer.x update 'PsLoc' preserving 'BufPos'. +-- +-- The parser guarantees that 'BufPos' are monotonic. See #17632. +newtype BufPos = BufPos { bufPos :: Int } + deriving (Eq, Ord, Show) + +-- | Source Location +data SrcLoc + = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos] + | UnhelpfulLoc FastString -- Just a general indication + deriving (Eq, Show) + +{- +************************************************************************ +* * +\subsection[SrcLoc-access-fns]{Access functions} +* * +************************************************************************ +-} + +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col + +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") + +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) + +advance_tabstop :: Int -> Int +advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 + +advanceBufPos :: BufPos -> BufPos +advanceBufPos (BufPos i) = BufPos (i+1) + +{- +************************************************************************ +* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +* * +************************************************************************ +-} + +sortLocated :: [Located a] -> [Located a] +sortLocated = sortBy (leftmost_smallest `on` getLoc) + +sortRealLocated :: [RealLocated a] -> [RealLocated a] +sortRealLocated = sortBy (compare `on` getLoc) + +lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a +lookupSrcLoc (RealSrcLoc l _) = Map.lookup l +lookupSrcLoc (UnhelpfulLoc _) = const Nothing + +lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a +lookupSrcSpan (RealSrcSpan l _) = Map.lookup l +lookupSrcSpan (UnhelpfulSpan _) = const Nothing + +instance Outputable RealSrcLoc where + ppr (SrcLoc src_path src_line src_col) + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l _) = ppr l + ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" + +{- +************************************************************************ +* * +\subsection[SrcSpan]{Source Spans} +* * +************************************************************************ +-} + +{- | +A 'RealSrcSpan' delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column /after/ the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} + +-- | Real Source Span +data RealSrcSpan + = RealSrcSpan' + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + deriving Eq + +-- | StringBuffer Source Span +data BufSpan = + BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } + deriving (Eq, Ord, Show) + +-- | Source Span +-- +-- A 'SrcSpan' identifies either a specific portion of a text file +-- or a human-readable description of a location. +data SrcSpan = + RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] + | UnhelpfulSpan !FastString -- Just a general indication + -- also used to indicate an empty span + + deriving (Eq, Show) -- Show is used by Lexer.x, because we + -- derive Show for Token + +{- Note [Why Maybe BufPos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). +Why the Maybe? + +Surely, the lexer can always fill in the buffer position, and it guarantees to do so. +However, sometimes the SrcLoc/SrcSpan is constructed in a different context +where the buffer location is not available, and then we use Nothing instead of +a fake value like BufPos (-1). + +Perhaps the compiler could be re-engineered to pass around BufPos more +carefully and never discard it, and this 'Maybe' could be removed. If you're +interested in doing so, you may find this ripgrep query useful: + + rg "RealSrc(Loc|Span).*?Nothing" + +For example, it is not uncommon to whip up source locations for e.g. error +messages, constructing a SrcSpan without a BufSpan. +-} + +instance ToJson SrcSpan where + json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (RealSrcSpan rss _) = json rss + +instance ToJson RealSrcSpan where + json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) + , ("startLine", JSInt srcSpanSLine) + , ("startCol", JSInt srcSpanSCol) + , ("endLine", JSInt srcSpanELine) + , ("endCol", JSInt srcSpanECol) + ] + +instance NFData SrcSpan where + rnf x = x `seq` () + +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "") +wiredInSrcSpan = UnhelpfulSpan (fsLit "") +interactiveSrcSpan = UnhelpfulSpan (fsLit "") + +-- | Create a "bad" 'SrcSpan' that has not location information +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan + +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col + +-- | Create a 'SrcSpan' between two points in a file +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +-- | 'True' if the span is known to straddle only one line. +isOneLineRealSpan :: RealSrcSpan -> Bool +isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) + = line1 == line2 + +-- | 'True' if the span is a single point +isPointRealSpan :: RealSrcSpan -> Bool +isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) + = line1 == line2 && col1 == col2 + +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Returns UnhelpfulSpan if the files differ. +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) + | srcSpanFile span1 == srcSpanFile span2 + = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) + | otherwise = UnhelpfulSpan (fsLit "") + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = RealSrcSpan' file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 + +combineBufSpans :: BufSpan -> BufSpan -> BufSpan +combineBufSpans span1 span2 = BufSpan start end + where + start = min (bufSpanStart span1) (bufSpanStart span2) + end = max (bufSpanEnd span1) (bufSpanEnd span2) + + +-- | Convert a SrcSpan into one that represents only its first character +srcSpanFirstCharacter :: SrcSpan -> SrcSpan +srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter (RealSrcSpan span mbspan) = + RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) + where + loc1@(SrcLoc f l c) = realSrcSpanStart span + loc2 = SrcLoc f l (c+1) + mkBufSpan bspan = + let bpos1@(BufPos i) = bufSpanStart bspan + bpos2 = BufPos (i+1) + in BufSpan bpos1 bpos2 + +{- +************************************************************************ +* * +\subsection[SrcSpan-predicates]{Predicates} +* * +************************************************************************ +-} + +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _ _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False + +isOneLineSpan :: SrcSpan -> Bool +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool +containsSpan s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanEndLine s1, srcSpanEndCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + -- We check file equality last because it is (presumably?) least + -- likely to fail. +{- +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +* * +************************************************************************ +-} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int + +srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l +srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l +srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l +srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c + +{- +************************************************************************ +* * +\subsection[SrcSpan-access-fns]{Access functions} +* * +************************************************************************ +-} + +-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanStart :: SrcSpan -> SrcLoc +srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) + +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc +srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing + +{- +************************************************************************ +* * +\subsection[SrcSpan-instances]{Instances} +* * +************************************************************************ +-} + +-- We want to order RealSrcSpans first by the start point, then by the +-- end point. +instance Ord RealSrcSpan where + a `compare` b = + (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` + (realSrcSpanEnd a `compare` realSrcSpanEnd b) + +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by Lexer.x, because we derive Show for Token +instance Show RealSrcSpan where + show span@(RealSrcSpan' file sl sc el ec) + | isPointRealSpan span + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) + + | isOneLineRealSpan span + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,ec]) + + | otherwise + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + + +instance Outputable RealSrcSpan where + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + +instance Outputable SrcSpan where + ppr span = pprUserSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) + | isPointRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] + +pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) + | isOneLineRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int scol + , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] + -- For single-character or point spans, we just + -- output the starting column number + +pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +{- +************************************************************************ +* * +\subsection[Located]{Attaching SrcSpans to things} +* * +************************************************************************ +-} + +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data GenLocated l e = L l e + deriving (Eq, Ord, Data, Functor, Foldable, Traversable) + +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan + +mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b +mapLoc = fmap + +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e + +getLoc :: GenLocated l e -> l +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal +eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things +cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where + ppr (L l e) = -- TODO: We can't do this since Located was refactored into + -- GenLocated: + -- Print spans without the file name etc + -- ifPprDebug (braces (pprUserSpan False l)) + whenPprDebug (braces (ppr l)) + $$ ppr e + +{- +************************************************************************ +* * +\subsection{Ordering SrcSpans for InteractiveUI} +* * +************************************************************************ +-} + +-- | Strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering +rightmost_smallest = compareSrcSpanBy (flip compare) +leftmost_smallest = compareSrcSpanBy compare +leftmost_largest = compareSrcSpanBy $ \a b -> + (realSrcSpanStart a `compare` realSrcSpanStart b) + `thenCmp` + (realSrcSpanEnd b `compare` realSrcSpanEnd a) + +compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering +compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b +compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c + +-- | Determines whether a span is enclosed by another one +isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent +isSubspanOf _ _ = False + +-- | Determines whether a span is enclosed by another one +isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other + -> RealSrcSpan -- ^ The span it may be enclosed by + -> Bool +isRealSubspanOf src parent + | srcSpanFile parent /= srcSpanFile src = False + | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && + realSrcSpanEnd parent >= realSrcSpanEnd src + +liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) +liftL f (L loc a) = do + a' <- f a + return $ L loc a' + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan (L l _) = l + +unRealSrcSpan :: RealLocated a -> a +unRealSrcSpan (L _ e) = e + + +-- | A location as produced by the parser. Consists of two components: +-- +-- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) +-- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) +data PsLoc + = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } + deriving (Eq, Ord, Show) + +data PsSpan + = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } + deriving (Eq, Ord, Show) + +type PsLocated = GenLocated PsSpan + +advancePsLoc :: PsLoc -> Char -> PsLoc +advancePsLoc (PsLoc real_loc buf_loc) c = + PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) + +mkPsSpan :: PsLoc -> PsLoc -> PsSpan +mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) + +psSpanStart :: PsSpan -> PsLoc +psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) + +psSpanEnd :: PsSpan -> PsLoc +psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) + +mkSrcSpanPs :: PsSpan -> SrcSpan +mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Unique.hs @@ -0,0 +1,448 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ + +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). +-} + +{-# LANGUAGE CPP, BangPatterns, MagicHash #-} + +module GHC.Types.Unique ( + -- * Main data types + Unique, Uniquable(..), + uNIQUE_BITS, + + -- ** Constructors, destructors and operations on 'Unique's + hasKey, + + pprUniqueAlways, + + mkUniqueGrimily, + getKey, + mkUnique, unpkUnique, + eqUnique, ltUnique, + incrUnique, + + newTagUnique, + initTyVarUnique, + initExitJoinUnique, + nonDetCmpUnique, + isValidKnownKeyUnique, + + -- ** Making built-in uniques + + -- now all the built-in GHC.Types.Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkAlphaTyVarUnique, + mkPrimOpIdUnique, mkPrimOpWrapperUnique, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkCoVarUnique, + + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkCostCentreUnique, + + mkBuiltinUnique, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH, + + -- ** Deriving uniques + -- *** From TyCon name uniques + tyConRepNameUnique, + -- *** From DataCon name uniques + dataConWorkerUnique, dataConTyRepNameUnique, + + -- ** Local uniques + -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which + -- has rather peculiar needs. See Note [Local uniques]. + mkLocalUnique, minLocalUnique, maxLocalUnique + ) where + +#include "HsVersions.h" +#include "Unique.h" + +import GhcPrelude + +import GHC.Types.Basic +import FastString +import Outputable +import Util + +-- just for implementing a fast [0,61) -> Char function +import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) + +import Data.Char ( chr, ord ) +import Data.Bits + +{- +************************************************************************ +* * +\subsection[Unique-type]{@Unique@ type and operations} +* * +************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: +-} + +-- | Unique identifier. +-- +-- The type of unique identifiers that are used in many places in GHC +-- for fast ordering and equality tests. You should generate these with +-- the functions from the 'UniqSupply' module +-- +-- These are sometimes also referred to as \"keys\" in comments in GHC. +newtype Unique = MkUnique Int + +{-# INLINE uNIQUE_BITS #-} +uNIQUE_BITS :: Int +uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS + +{- +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. +-} + +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Int -- for Var + +incrUnique :: Unique -> Unique +stepUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique + +mkUniqueGrimily = MkUnique + +{-# INLINE getKey #-} +getKey (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i + 1) +stepUnique (MkUnique i) n = MkUnique (i + n) + +mkLocalUnique :: Int -> Unique +mkLocalUnique i = mkUnique 'X' i + +minLocalUnique :: Unique +minLocalUnique = mkLocalUnique 0 + +maxLocalUnique :: Unique +maxLocalUnique = mkLocalUnique uniqueMask + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- | How many bits are devoted to the unique index (as opposed to the class +-- character). +uniqueMask :: Int +uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +-- and as long as the Char fits in 8 bits, which we assume anyway! + +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module +mkUnique c i + = MkUnique (tag .|. bits) + where + tag = ord c `shiftL` uNIQUE_BITS + bits = i .&. uniqueMask + +unpkUnique (MkUnique u) + = let + -- as long as the Char may have its eighth bit set, we + -- really do need the logical right-shift here! + tag = chr (u `shiftR` uNIQUE_BITS) + i = u .&. uniqueMask + in + (tag, i) + +-- | The interface file symbol-table encoding assumes that known-key uniques fit +-- in 30-bits; verify this. +-- +-- See Note [Symbol table representation of names] in GHC.Iface.Binary for details. +isValidKnownKeyUnique :: Unique -> Bool +isValidKnownKeyUnique u = + case unpkUnique u of + (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) + +{- +************************************************************************ +* * +\subsection[Uniquable-class]{The @Uniquable@ class} +* * +************************************************************************ +-} + +-- | Class of things that we can obtain a 'Unique' from +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueGrimily (uniqueOfFS fs) + +instance Uniquable Int where + getUnique i = mkUniqueGrimily i + +{- +************************************************************************ +* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +* * +************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). +-} + +-- Note [Unique Determinism] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of allocated @Uniques@ is not stable across rebuilds. +-- The main reason for that is that typechecking interface files pulls +-- @Uniques@ from @UniqSupply@ and the interface file for the module being +-- currently compiled can, but doesn't have to exist. +-- +-- It gets more complicated if you take into account that the interface +-- files are loaded lazily and that building multiple files at once has to +-- work for any subset of interface files present. When you add parallelism +-- this makes @Uniques@ hopelessly random. +-- +-- As such, to get deterministic builds, the order of the allocated +-- @Uniques@ should not affect the final result. +-- see also wiki/deterministic-builds +-- +-- Note [Unique Determinism and code generation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The goal of the deterministic builds (wiki/deterministic-builds, #4012) +-- is to get ABI compatible binaries given the same inputs and environment. +-- The motivation behind that is that if the ABI doesn't change the +-- binaries can be safely reused. +-- Note that this is weaker than bit-for-bit identical binaries and getting +-- bit-for-bit identical binaries is not a goal for now. +-- This means that we don't care about nondeterminism that happens after +-- the interface files are created, in particular we don't care about +-- register allocation and code generation. +-- To track progress on bit-for-bit determinism see #12262. + +eqUnique :: Unique -> Unique -> Bool +eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 + +ltUnique :: Unique -> Unique -> Bool +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 + +-- Provided here to make it explicit at the call-site that it can +-- introduce non-determinism. +-- See Note [Unique Determinism] +-- See Note [No Ord for Unique] +nonDetCmpUnique :: Unique -> Unique -> Ordering +nonDetCmpUnique (MkUnique u1) (MkUnique u2) + = if u1 == u2 then EQ else if u1 < u2 then LT else GT + +{- +Note [No Ord for Unique] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Unique Determinism] the relative order of Uniques +is nondeterministic. To prevent from accidental use the Ord Unique +instance has been removed. +This makes it easier to maintain deterministic builds, but comes with some +drawbacks. +The biggest drawback is that Maps keyed by Uniques can't directly be used. +The alternatives are: + + 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which + 2) Create a newtype wrapper based on Unique ordering where nondeterminism + is controlled. See Module.ModuleEnv + 3) Change the algorithm to use nonDetCmpUnique and document why it's still + deterministic + 4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel +-} + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Uniquable Unique where + getUnique u = u + +-- We do sometimes make strings with @Uniques@ in them: + +showUnique :: Unique -> String +showUnique uniq + = case unpkUnique uniq of + (tag, u) -> finish_show tag u (iToBase62 u) + +finish_show :: Char -> Int -> String -> String +finish_show 't' u _pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + [chr (ord 'a' + u)] +finish_show tag _ pp_u = tag : pp_u + +pprUniqueAlways :: Unique -> SDoc +-- The "always" means regardless of -dsuppress-uniques +-- It replaces the old pprUnique to remind callers that +-- they should consider whether they want to consult +-- Opt_SuppressUniques +pprUniqueAlways u + = text (showUnique u) + +instance Outputable Unique where + ppr = pprUniqueAlways + +instance Show Unique where + show uniq = showUnique uniq + +{- +************************************************************************ +* * +\subsection[Utils-base62]{Base-62 numbers} +* * +************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. +-} + +iToBase62 :: Int -> String +iToBase62 n_ + = ASSERT(n_ >= 0) go n_ "" + where + go n cs | n < 62 + = let !c = chooseChar62 n in c : cs + | otherwise + = go q (c : cs) where (!q, r) = quotRem n 62 + !c = chooseChar62 r + + chooseChar62 :: Int -> Char + {-# INLINE chooseChar62 #-} + chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) + chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + +{- +************************************************************************ +* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +* * +************************************************************************ + +Allocation of unique supply characters: + v,t,u : for renumbering value-, type- and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + X: uniques from mkLocalUnique + _: unifiable tyvars (above) + 0-9: prelude things below + (no numbers left any more..) + :: (prelude) parallel array data constructors + + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + k constraint tuple tycons + m constraint tuple datacons + n Native codegen + r Hsc name cache + s simplifier + z anonymous sums +-} + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPreludeTyConUnique :: Int -> Unique +mkPreludeDataConUnique :: Arity -> Unique +mkPrimOpIdUnique :: Int -> Unique +-- See Note [Primop wrappers] in PrimOp.hs. +mkPrimOpWrapperUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique +mkCoVarUnique :: Int -> Unique + +mkAlphaTyVarUnique i = mkUnique '1' i +mkCoVarUnique i = mkUnique 'g' i +mkPreludeClassUnique i = mkUnique '2' i + +-------------------------------------------------- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +mkPreludeTyConUnique i = mkUnique '3' (2*i) + +tyConRepNameUnique :: Unique -> Unique +tyConRepNameUnique u = incrUnique u + +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon +-- Prelude data constructors are too simple to need wrappers. + +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic + +-------------------------------------------------- +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConWorkerUnique u = incrUnique u +dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +mkPrimOpIdUnique op = mkUnique '9' (2*op) +mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) +mkPreludeMiscIdUnique i = mkUnique '0' i + +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUnique 'C' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence +mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) +mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) +mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) +mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) + +initExitJoinUnique :: Unique +initExitJoinUnique = mkUnique 's' 0 + diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -0,0 +1,420 @@ +{- +(c) Bartosz Nitka, Facebook, 2015 + +UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +This is very similar to @UniqFM@, the major difference being that the order of +folding is not dependent on @Unique@ ordering, giving determinism. +Currently the ordering is determined by insertion order. + +See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ ordering +is not deterministic. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.DFM ( + -- * Unique-keyed deterministic mappings + UniqDFM, -- abstract type + + -- ** Manipulating those mappings + emptyUDFM, + unitUDFM, + addToUDFM, + addToUDFM_C, + addListToUDFM, + delFromUDFM, + delListFromUDFM, + adjustUDFM, + alterUDFM, + mapUDFM, + plusUDFM, + plusUDFM_C, + lookupUDFM, lookupUDFM_Directly, + elemUDFM, + foldUDFM, + eltsUDFM, + filterUDFM, filterUDFM_Directly, + isNullUDFM, + sizeUDFM, + intersectUDFM, udfmIntersectUFM, + intersectsUDFM, + disjointUDFM, disjointUdfmUfm, + equalKeysUDFM, + minusUDFM, + listToUDFM, + udfmMinusUFM, + partitionUDFM, + anyUDFM, allUDFM, + pprUniqDFM, pprUDFM, + + udfmToList, + udfmToUfm, + nonDetFoldUDFM, + alwaysUnsafeUfmToUdfm, + ) where + +import GhcPrelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import qualified Data.IntMap as M +import Data.Data +import Data.Functor.Classes (Eq1 (..)) +import Data.List (sortBy) +import Data.Function (on) +import qualified Data.Semigroup as Semi +import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) + +-- Note [Deterministic UniqFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A @UniqDFM@ is just like @UniqFM@ with the following additional +-- property: the function `udfmToList` returns the elements in some +-- deterministic order not depending on the Unique key for those elements. +-- +-- If the client of the map performs operations on the map in deterministic +-- order then `udfmToList` returns them in deterministic order. +-- +-- There is an implementation cost: each element is given a serial number +-- as it is added, and `udfmToList` sorts it's result by this serial +-- number. So you should only use `UniqDFM` if you need the deterministic +-- property. +-- +-- `foldUDFM` also preserves determinism. +-- +-- Normal @UniqFM@ when you turn it into a list will use +-- Data.IntMap.toList function that returns the elements in the order of +-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with +-- with a list ordered by @Uniques@. +-- The order of @Uniques@ is known to be not stable across rebuilds. +-- See Note [Unique Determinism] in GHC.Types.Unique. +-- +-- +-- There's more than one way to implement this. The implementation here tags +-- every value with the insertion time that can later be used to sort the +-- values when asked to convert to a list. +-- +-- An alternative would be to have +-- +-- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- +-- where the list determines the order. This makes deletion tricky as we'd +-- only accumulate elements in that list, but makes merging easier as you +-- can just merge both structures independently. +-- Deletion can probably be done in amortized fashion when the size of the +-- list is twice the size of the set. + +-- | A type of values tagged with insertion time +data TaggedVal val = + TaggedVal + val + {-# UNPACK #-} !Int -- ^ insertion time + deriving (Data, Functor) + +taggedFst :: TaggedVal val -> val +taggedFst (TaggedVal v _) = v + +taggedSnd :: TaggedVal val -> Int +taggedSnd (TaggedVal _ i) = i + +instance Eq val => Eq (TaggedVal val) where + (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 + +-- | Type of unique deterministic finite maps +data UniqDFM ele = + UDFM + !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and + -- values are tagged with insertion time. + -- The invariant is that all the tags will + -- be distinct within a single map + {-# UNPACK #-} !Int -- Upper bound on the values' insertion + -- time. See Note [Overflow on plusUDFM] + deriving (Data, Functor) + +-- | Deterministic, in O(n log n). +instance Foldable UniqDFM where + foldr = foldUDFM + +-- | Deterministic, in O(n log n). +instance Traversable UniqDFM where + traverse f = fmap listToUDFM_Directly + . traverse (\(u,a) -> (u,) <$> f a) + . udfmToList + +emptyUDFM :: UniqDFM elt +emptyUDFM = UDFM M.empty 0 + +unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt +unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 + +-- The new binding always goes to the right of existing ones +addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt +addToUDFM m k v = addToUDFM_Directly m (getUnique k) v + +-- The new binding always goes to the right of existing ones +addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt +addToUDFM_Directly (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i + -- Keep the old tag, but insert the new value + -- This means that udfmToList typically returns elements + -- in the order of insertion, rather than the reverse + +addToUDFM_Directly_C + :: (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM elt + -> Unique -> elt + -> UniqDFM elt +addToUDFM_Directly_C f (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal old_v old_i) + = TaggedVal (f old_v new_v) old_i + -- Flip the arguments, because M.insertWith uses (new->old->result) + -- but f needs (old->new->result) + -- Like addToUDFM_Directly, keep the old tag + +addToUDFM_C + :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM elt -- old + -> key -> elt -- new + -> UniqDFM elt -- result +addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v + +addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt +addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) + +addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt +addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) + +addListToUDFM_Directly_C + :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt +addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) + +delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt +delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i + +plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt +plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_C f udfml udfmr + | otherwise = insertUDFMIntoLeft_C f udfmr udfml + +-- Note [Overflow on plusUDFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are multiple ways of implementing plusUDFM. +-- The main problem that needs to be solved is overlap on times of +-- insertion between different keys in two maps. +-- Consider: +-- +-- A = fromList [(a, (x, 1))] +-- B = fromList [(b, (y, 1))] +-- +-- If you merge them naively you end up with: +-- +-- C = fromList [(a, (x, 1)), (b, (y, 1))] +-- +-- Which loses information about ordering and brings us back into +-- non-deterministic world. +-- +-- The solution I considered before would increment the tags on one of the +-- sets by the upper bound of the other set. The problem with this approach +-- is that you'll run out of tags for some merge patterns. +-- Say you start with A with upper bound 1, you merge A with A to get A' and +-- the upper bound becomes 2. You merge A' with A' and the upper bound +-- doubles again. After 64 merges you overflow. +-- This solution would have the same time complexity as plusUFM, namely O(n+m). +-- +-- The solution I ended up with has time complexity of +-- O(m log m + m * min (n+m, W)) where m is the smaller set. +-- It simply inserts the elements of the smaller set into the larger +-- set in the order that they were inserted into the smaller set. That's +-- O(m log m) for extracting the elements from the smaller set in the +-- insertion order and O(m * min(n+m, W)) to insert them into the bigger +-- set. + +plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft udfml udfmr + | otherwise = insertUDFMIntoLeft udfmr udfml + +insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr + +insertUDFMIntoLeft_C + :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt +insertUDFMIntoLeft_C f udfml udfmr = + addListToUDFM_Directly_C f udfml $ udfmToList udfmr + +lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt +lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m + +lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt +lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m + +elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool +elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m + +-- | Performs a deterministic fold over the UniqDFM. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +foldUDFM k z m = foldr k z (eltsUDFM m) + +-- | Performs a nondeterministic fold over the UniqDFM. +-- It's O(n), same as the corresponding function on `UniqFM`. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m + +eltsUDFM :: UniqDFM elt -> [elt] +eltsUDFM (UDFM m _i) = + map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m + +filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt +filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i + +filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt +filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i + where + p' k (TaggedVal v _) = p (getUnique k) v + +-- | Converts `UniqDFM` to a list, with elements in deterministic order. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +udfmToList :: UniqDFM elt -> [(Unique, elt)] +udfmToList (UDFM m _i) = + [ (getUnique k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] + +-- Determines whether two 'UniqDFM's contain the same keys. +equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool +equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 + +isNullUDFM :: UniqDFM elt -> Bool +isNullUDFM (UDFM m _) = M.null m + +sizeUDFM :: UniqDFM elt -> Int +sizeUDFM (UDFM m _i) = M.size m + +intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) + +disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) + +disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool +disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) + +minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 +minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +-- | Partition UniqDFM into two UniqDFMs according to the predicate +partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) +partitionUDFM p (UDFM m i) = + case M.partition (p . taggedFst) m of + (left, right) -> (UDFM left i, UDFM right i) + +-- | Delete a list of elements from a UniqDFM +delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt +delListFromUDFM = foldl' delFromUDFM + +-- | This allows for lossy conversion from UniqDFM to UniqFM +udfmToUfm :: UniqDFM elt -> UniqFM elt +udfmToUfm (UDFM m _i) = + listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] + +listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt +listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM + +listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt +listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM + +-- | Apply a function to a particular element +adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt +adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i + +-- | The expression (alterUDFM f k map) alters value x at k, or absence +-- thereof. alterUDFM can be used to insert, delete, or update a value in +-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are +-- more efficient. +alterUDFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqDFM elt -- old + -> key -- new + -> UniqDFM elt -- result +alterUDFM f (UDFM m i) k = + UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) + where + alterf Nothing = inject $ f Nothing + alterf (Just (TaggedVal v _)) = inject $ f (Just v) + inject Nothing = Nothing + inject (Just v) = Just $ TaggedVal v i + +-- | Map a function over every value in a UniqDFM +mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 +mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i + +anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool +anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m + +allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool +allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m + +instance Semi.Semigroup (UniqDFM a) where + (<>) = plusUDFM + +instance Monoid (UniqDFM a) where + mempty = emptyUDFM + mappend = (Semi.<>) + +-- This should not be used in committed code, provided for convenience to +-- make ad-hoc conversions when developing +alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt +alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList + +-- Output-ery + +instance Outputable a => Outputable (UniqDFM a) where + ppr ufm = pprUniqDFM ppr ufm + +pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc +pprUniqDFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- udfmToList ufm ] + +pprUDFM :: UniqDFM a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/compiler/GHC/Types/Unique/DSet.hs b/compiler/GHC/Types/Unique/DSet.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Unique/DSet.hs @@ -0,0 +1,141 @@ +-- (c) Bartosz Nitka, Facebook, 2015 + +-- | +-- Specialised deterministic sets, for things with @Uniques@ +-- +-- Based on 'UniqDFM's (as you would expect). +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need it. +-- +-- Basically, the things need to be in class 'Uniquable'. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.DSet ( + -- * Unique set type + UniqDSet, -- type synonym for UniqFM a + getUniqDSet, + pprUniqDSet, + + -- ** Manipulating these sets + delOneFromUniqDSet, delListFromUniqDSet, + emptyUniqDSet, + unitUniqDSet, + mkUniqDSet, + addOneToUniqDSet, addListToUniqDSet, + unionUniqDSets, unionManyUniqDSets, + minusUniqDSet, uniqDSetMinusUniqSet, + intersectUniqDSets, uniqDSetIntersectUniqSet, + foldUniqDSet, + elementOfUniqDSet, + filterUniqDSet, + sizeUniqDSet, + isEmptyUniqDSet, + lookupUniqDSet, + uniqDSetToList, + partitionUniqDSet, + mapUniqDSet + ) where + +import GhcPrelude + +import Outputable +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Unique + +import Data.Coerce +import Data.Data +import qualified Data.Semigroup as Semi + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. +-- Beyond preserving invariants, we may also want to 'override' typeclass +-- instances. + +newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqDSet :: UniqDSet a +emptyUniqDSet = UniqDSet emptyUDFM + +unitUniqDSet :: Uniquable a => a -> UniqDSet a +unitUniqDSet x = UniqDSet (unitUDFM x x) + +mkUniqDSet :: Uniquable a => [a] -> UniqDSet a +mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet + +-- The new element always goes to the right of existing ones. +addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) + +addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +addListToUniqDSet = foldl' addOneToUniqDSet + +delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s + +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s + +unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) + +unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a +unionManyUniqDSets [] = emptyUniqDSet +unionManyUniqDSets sets = foldr1 unionUniqDSets sets + +minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a +minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) + +uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a +uniqDSetMinusUniqSet xs ys + = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) + +intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) + +uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a +uniqDSetIntersectUniqSet xs ys + = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) + +foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b +foldUniqDSet c n (UniqDSet s) = foldUDFM c n s + +elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool +elementOfUniqDSet k = elemUDFM k . getUniqDSet + +filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a +filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) + +sizeUniqDSet :: UniqDSet a -> Int +sizeUniqDSet = sizeUDFM . getUniqDSet + +isEmptyUniqDSet :: UniqDSet a -> Bool +isEmptyUniqDSet = isNullUDFM . getUniqDSet + +lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a +lookupUniqDSet = lookupUDFM . getUniqDSet + +uniqDSetToList :: UniqDSet a -> [a] +uniqDSetToList = eltsUDFM . getUniqDSet + +partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) +partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set +mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList + +-- Two 'UniqDSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqDSet a) where + UniqDSet a == UniqDSet b = equalKeysUDFM a b + +getUniqDSet :: UniqDSet a -> UniqDFM a +getUniqDSet = getUniqDSet' + +instance Outputable a => Outputable (UniqDSet a) where + ppr = pprUniqDSet ppr + +pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc +pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Unique/FM.hs @@ -0,0 +1,416 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +UniqFM: Specialised finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +The interface is based on @FiniteMap@s, but the implementation uses +@Data.IntMap@, which is both maintained and faster than the past +implementation (see commit log). + +The @UniqFM@ interface maps directly to Data.IntMap, only +``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased +and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order +of arguments of combining function. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.FM ( + -- * Unique-keyed mappings + UniqFM, -- abstract type + NonDetUniqFM(..), -- wrapper for opting into nondeterminism + + -- ** Manipulating those mappings + emptyUFM, + unitUFM, + unitDirectlyUFM, + listToUFM, + listToUFM_Directly, + listToUFM_C, + addToUFM,addToUFM_C,addToUFM_Acc, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + adjustUFM, alterUFM, + adjustUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + delListFromUFM_Directly, + plusUFM, + plusUFM_C, + plusUFM_CD, + plusMaybeUFM_C, + plusUFMList, + minusUFM, + intersectUFM, + intersectUFM_C, + disjointUFM, + equalKeysUFM, + nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, + anyUFM, allUFM, seqEltsUFM, + mapUFM, mapUFM_Directly, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, + sizeUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + nonDetEltsUFM, eltsUFM, nonDetKeysUFM, + ufmToSet_Directly, + nonDetUFMToList, ufmToIntMap, + pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM + ) where + +import GhcPrelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import qualified Data.IntMap as M +import qualified Data.IntSet as S +import Data.Data +import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) + + +newtype UniqFM ele = UFM (M.IntMap ele) + deriving (Data, Eq, Functor) + -- Nondeterministic Foldable and Traversable instances are accessible through + -- use of the 'NonDetUniqFM' wrapper. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. + +emptyUFM :: UniqFM elt +emptyUFM = UFM M.empty + +isNullUFM :: UniqFM elt -> Bool +isNullUFM (UFM m) = M.null m + +unitUFM :: Uniquable key => key -> elt -> UniqFM elt +unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) + +-- when you've got the Unique already +unitDirectlyUFM :: Unique -> elt -> UniqFM elt +unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) + +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt +listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM + +listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt +listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM + +listToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> [(key, elt)] + -> UniqFM elt +listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM + +addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) + +addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) + +addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt +addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) + +addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt +addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) + +addToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- old -> new -> result + -> UniqFM elt -- old + -> key -> elt -- new + -> UniqFM elt -- result +-- Arguments of combining function of M.insertWith and addToUFM_C are flipped. +addToUFM_C f (UFM m) k v = + UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) + +addToUFM_Acc + :: Uniquable key + => (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- result +addToUFM_Acc exi new (UFM m) k v = + UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) + +alterUFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqFM elt -- old + -> key -- new + -> UniqFM elt -- result +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) + +addListToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> UniqFM elt -> [(key,elt)] + -> UniqFM elt +addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) + +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) + +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + +delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt +delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) + +delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt +delListFromUFM = foldl' delFromUFM + +delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt +delListFromUFM_Directly = foldl' delFromUFM_Directly + +delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt +delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) + +-- Bindings in right argument shadow those in the left +plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +-- M.union is left-biased, plusUFM should be right-biased. +plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + +plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt +plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +plusUFM_CD + :: (elt -> elt -> elt) + -> UniqFM elt -- map X + -> elt -- default for X + -> UniqFM elt -- map Y + -> elt -- default for Y + -> UniqFM elt +plusUFM_CD f (UFM xm) dx (UFM ym) dy + = UFM $ M.mergeWithKey + (\_ x y -> Just (x `f` y)) + (M.map (\x -> x `f` dy)) + (M.map (\y -> dx `f` y)) + xm ym + +plusMaybeUFM_C :: (elt -> elt -> Maybe elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt +plusMaybeUFM_C f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> x `f` y) + id + id + xm ym + +plusUFMList :: [UniqFM elt] -> UniqFM elt +plusUFMList = foldl' plusUFM emptyUFM + +minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 +minusUFM (UFM x) (UFM y) = UFM (M.difference x y) + +intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 +intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) + +intersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM elt1 + -> UniqFM elt2 + -> UniqFM elt3 +intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool +disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) + +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +foldUFM k z (UFM m) = M.foldr k z m + +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM f (UFM m) = UFM (M.map f m) + +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) + +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM p (UFM m) = UFM (M.filter p m) + +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) + +partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) +partitionUFM p (UFM m) = + case M.partition p m of + (left, right) -> (UFM left, UFM right) + +sizeUFM :: UniqFM elt -> Int +sizeUFM (UFM m) = M.size m + +elemUFM :: Uniquable key => key -> UniqFM elt -> Bool +elemUFM k (UFM m) = M.member (getKey $ getUnique k) m + +elemUFM_Directly :: Unique -> UniqFM elt -> Bool +elemUFM_Directly u (UFM m) = M.member (getKey u) m + +lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt +lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m + +-- when you've got the Unique already +lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt +lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m + +lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt +lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m + +lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt +lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m + +eltsUFM :: UniqFM elt -> [elt] +eltsUFM (UFM m) = M.elems m + +ufmToSet_Directly :: UniqFM elt -> S.IntSet +ufmToSet_Directly (UFM m) = M.keysSet m + +anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool +anyUFM p (UFM m) = M.foldr ((||) . p) False m + +allUFM :: (elt -> Bool) -> UniqFM elt -> Bool +allUFM p (UFM m) = M.foldr ((&&) . p) True m + +seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () +seqEltsUFM seqList = seqList . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM here because the type guarantees that + -- the only interesting thing this function can do is to force the + -- elements. + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUFM :: UniqFM elt -> [elt] +nonDetEltsUFM (UFM m) = M.elems m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUFM :: UniqFM elt -> [Unique] +nonDetKeysUFM (UFM m) = map getUnique $ M.keys m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +nonDetFoldUFM k z (UFM m) = M.foldr k z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] +nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m + +-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites +-- that the provided 'Foldable' and 'Traversable' instances are +-- nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. +newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } + deriving (Functor) + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. +instance Foldable NonDetUniqFM where + foldr f z (NonDetUniqFM (UFM m)) = foldr f z m + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. +instance Traversable NonDetUniqFM where + traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m + +ufmToIntMap :: UniqFM elt -> M.IntMap elt +ufmToIntMap (UFM m) = m + +-- Determines whether two 'UniqFM's contain the same keys. +equalKeysUFM :: UniqFM a -> UniqFM b -> Bool +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +-- Instances + +instance Semi.Semigroup (UniqFM a) where + (<>) = plusUFM + +instance Monoid (UniqFM a) where + mempty = emptyUFM + mappend = (Semi.<>) + +-- Output-ery + +instance Outputable a => Outputable (UniqFM a) where + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- nonDetUFMToList ufm ] + -- It's OK to use nonDetUFMToList here because we only use it for + -- pretty-printing. + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +pprUFM :: UniqFM a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFM ufm pp = pp (nonDetEltsUFM ufm) + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetUFMToList. +pprUFMWithKeys + :: UniqFM a -- ^ The things to be pretty printed + -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralUFM :: UniqFM a -> SDoc +pluralUFM ufm + | sizeUFM ufm == 1 = empty + | otherwise = char 's' diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Unique/Set.hs @@ -0,0 +1,195 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @Uniquable@. +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.Set ( + -- * Unique set type + UniqSet, -- type synonym for UniqFM a + getUniqSet, + pprUniqSet, + + -- ** Manipulating these sets + emptyUniqSet, + unitUniqSet, + mkUniqSet, + addOneToUniqSet, addListToUniqSet, + delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, + delListFromUniqSet_Directly, + unionUniqSets, unionManyUniqSets, + minusUniqSet, uniqSetMinusUFM, + intersectUniqSets, + restrictUniqSetToUFM, + uniqSetAny, uniqSetAll, + elementOfUniqSet, + elemUniqSet_Directly, + filterUniqSet, + filterUniqSet_Directly, + sizeUniqSet, + isEmptyUniqSet, + lookupUniqSet, + lookupUniqSet_Directly, + partitionUniqSet, + mapUniqSet, + unsafeUFMToUniqSet, + nonDetEltsUniqSet, + nonDetKeysUniqSet, + nonDetFoldUniqSet, + nonDetFoldUniqSet_Directly + ) where + +import GhcPrelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique +import Data.Coerce +import Outputable +import Data.Data +import qualified Data.Semigroup as Semi + +-- Note [UniqSet invariant] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- UniqSet has the following invariant: +-- The keys in the map are the uniques of the values +-- It means that to implement mapUniqSet you have to update +-- both the keys and the values. + +newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqSet :: UniqSet a +emptyUniqSet = UniqSet emptyUFM + +unitUniqSet :: Uniquable a => a -> UniqSet a +unitUniqSet x = UniqSet $ unitUFM x x + +mkUniqSet :: Uniquable a => [a] -> UniqSet a +mkUniqSet = foldl' addOneToUniqSet emptyUniqSet + +addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) + +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +addListToUniqSet = foldl' addOneToUniqSet + +delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) + +delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a +delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) + +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) + +delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a +delListFromUniqSet_Directly (UniqSet s) l = + UniqSet (delListFromUFM_Directly s l) + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a +unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) + +restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a +restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) + +uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a +uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) + +elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool +elementOfUniqSet a (UniqSet s) = elemUFM a s + +elemUniqSet_Directly :: Unique -> UniqSet a -> Bool +elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s + +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) + +filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt +filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) + +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) +partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) + +uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAny p (UniqSet s) = anyUFM p s + +uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAll p (UniqSet s) = allUFM p s + +sizeUniqSet :: UniqSet a -> Int +sizeUniqSet (UniqSet s) = sizeUFM s + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (UniqSet s) = isNullUFM s + +lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b +lookupUniqSet (UniqSet s) k = lookupUFM s k + +lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a +lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUniqSet :: UniqSet elt -> [elt] +nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUniqSet :: UniqSet elt -> [Unique] +nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a +nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a +nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s + +-- See Note [UniqSet invariant] +mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet + +-- Two 'UniqSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqSet a) where + UniqSet a == UniqSet b = equalKeysUFM a b + +getUniqSet :: UniqSet a -> UniqFM a +getUniqSet = getUniqSet' + +-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ +-- assuming, without checking, that it maps each 'Unique' to a value +-- that has that 'Unique'. See Note [UniqSet invariant]. +unsafeUFMToUniqSet :: UniqFM a -> UniqSet a +unsafeUFMToUniqSet = UniqSet + +instance Outputable a => Outputable (UniqSet a) where + ppr = pprUniqSet ppr + +pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc +-- It's OK to use nonDetUFMToList here because we only use it for +-- pretty-printing. +pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -0,0 +1,223 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} + +#if !defined(GHC_LOADED_INTO_GHCI) +{-# LANGUAGE UnboxedTuples #-} +#endif + +module GHC.Types.Unique.Supply ( + -- * Main data type + UniqSupply, -- Abstractly + + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, uniqFromMask, + + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, + + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), + + -- ** Operations on the monad + initUs, initUs_, + + -- * Set supply strategy + initUniqSupply + ) where + +import GhcPrelude + +import GHC.Types.Unique +import PlainPanic (panic) + +import GHC.IO + +import MonadUtils +import Control.Monad +import Data.Bits +import Data.Char + +#include "Unique.h" + +{- +************************************************************************ +* * +\subsection{Splittable Unique supply: @UniqSupply@} +* * +************************************************************************ +-} + +-- | Unique Supply +-- +-- A value of type 'UniqSupply' is unique, and it can +-- supply /one/ distinct 'Unique'. Also, from the supply, one can +-- also manufacture an arbitrary number of further 'UniqueSupply' values, +-- which will be distinct from the first and from all others. +data UniqSupply + = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies + +mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ Create a unique supply out of thin air. The character given must +-- be distinct from those of all calls to this function in the compiler +-- for the values generated to be truly unique. + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ Build two 'UniqSupply' from a single one, each of which +-- can supply its own 'Unique'. +listSplitUniqSupply :: UniqSupply -> [UniqSupply] +-- ^ Create an infinite list of 'UniqSupply' from a single one +uniqFromSupply :: UniqSupply -> Unique +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply + +uniqFromMask :: Char -> IO Unique +uniqFromMask mask + = do { uqNum <- genSym + ; return $! mkUnique mask uqNum } + +mkSplitUniqSupply c + = case ord c `shiftL` uNIQUE_BITS of + !mask -> let + -- here comes THE MAGIC: + + -- This is one of the most hammered bits in the whole compiler + mk_supply + -- NB: Use unsafeInterleaveIO for thread-safety. + = unsafeInterleaveIO ( + genSym >>= \ u -> + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (mask .|. u) s1 s2) + ) + in + mk_supply + +foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int +foreign import ccall unsafe "ghc_lib_parser_initGenSym" initUniqSupply :: Int -> Int -> IO () + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 + +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) + +{- +************************************************************************ +* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +* * +************************************************************************ +-} + +-- Avoids using unboxed tuples when loading into GHCi +#if !defined(GHC_LOADED_INTO_GHCI) + +type UniqResult result = (# result, UniqSupply #) + +pattern UniqResult :: a -> b -> (# a, b #) +pattern UniqResult x y = (# x, y #) +{-# COMPLETE UniqResult #-} + +#else + +data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply + deriving (Functor) + +#endif + +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } + deriving (Functor) + +instance Monad UniqSM where + (>>=) = thenUs + (>>) = (*>) + +instance Applicative UniqSM where + pure = returnUs + (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of + UniqResult ff us1 -> case x us1 of + UniqResult xx us2 -> UniqResult (ff xx) us2 + (*>) = thenUs_ + +-- TODO: try to get rid of this instance +instance MonadFail UniqSM where + fail = panic + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } + +{-# INLINE thenUs #-} +{-# INLINE returnUs #-} +{-# INLINE splitUniqSupply #-} + +-- @thenUs@ is where we split the @UniqSupply@. + +liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) +liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) + +instance MonadFix UniqSM where + mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) + +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +thenUs (USM expr) cont + = USM (\us0 -> case (expr us0) of + UniqResult result us1 -> unUSM (cont result) us1) + +thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b +thenUs_ (USM expr) (USM cont) + = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) + +returnUs :: a -> UniqSM a +returnUs result = USM (\us -> UniqResult result us) + +getUs :: UniqSM UniqSupply +getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) + +-- | A monad for generating unique identifiers +class Monad m => MonadUnique m where + -- | Get a new UniqueSupply + getUniqueSupplyM :: m UniqSupply + -- | Get a new unique identifier + getUniqueM :: m Unique + -- | Get an infinite list of new unique identifiers + getUniquesM :: m [Unique] + + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = getUs + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs + +getUniqueUs :: UniqSM Unique +getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of + (u,us1) -> UniqResult u us1) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of + (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Var.hs @@ -0,0 +1,763 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{@Vars@: Variables} +-} + +{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'GHC.Core.TyCo.Rep.Kind' +-- rather than a 'GHC.Core.TyCo.Rep.Type' and only contain some extra +-- details during typechecking. +-- +-- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" +-- +-- #globalvslocal# +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + +module GHC.Types.Var ( + -- * The main data type and synonyms + Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, + TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, + + -- * In and Out variants + InVar, InCoVar, InId, InTyVar, + OutVar, OutCoVar, OutId, OutTyVar, + + -- ** Taking 'Var's apart + varName, varUnique, varType, + + -- ** Modifying 'Var's + setVarName, setVarUnique, setVarType, updateVarType, + updateVarTypeM, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, + + -- ** Predicates + isId, isTyVar, isTcTyVar, + isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, + isGlobalId, isExportedId, + mustHaveLocalBinding, + + -- * ArgFlags + ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, + AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, + + -- * TyVar's + VarBndr(..), TyCoVarBinder, TyVarBinder, + binderVar, binderVars, binderArgFlag, binderType, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinder, mkTyVarBinders, + isTyVarBinder, + + -- ** Constructing TyVar's + mkTyVar, mkTcTyVar, + + -- ** Taking 'TyVar's apart + tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, + + -- ** Modifying 'TyVar's + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM, + + nonDetCmpVar + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) +import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) +import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, + vanillaIdInfo, pprIdDetails ) + +import GHC.Types.Name hiding (varName) +import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique + , mkUniqueGrimily, nonDetCmpUnique ) +import Util +import Binary +import Outputable + +import Data.Data + +{- +************************************************************************ +* * + Synonyms +* * +************************************************************************ +-- These synonyms are here and not in Id because otherwise we need a very +-- large number of SOURCE imports of Id.hs :-( +-} + +-- | Identifier +type Id = Var -- A term-level identifier + -- predicate: isId + +-- | Coercion Variable +type CoVar = Id -- See Note [Evidence: EvIds and CoVars] + -- predicate: isCoVar + +-- | +type NcId = Id -- A term-level (value) variable that is + -- /not/ an (unlifted) coercion + -- predicate: isNonCoVarId + +-- | Type or kind Variable +type TyVar = Var -- Type *or* kind variable (historical) + +-- | Type or Kind Variable +type TKVar = Var -- Type *or* kind variable (historical) + +-- | Type variable that might be a metavariable +type TcTyVar = Var + +-- | Type Variable +type TypeVar = Var -- Definitely a type variable + +-- | Kind Variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] + +-- See Note [Evidence: EvIds and CoVars] +-- | Evidence Identifier +type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar + +-- | Evidence Variable +type EvVar = EvId -- ...historical name for EvId + +-- | Dictionary Function Identifier +type DFunId = Id -- A dictionary function + +-- | Dictionary Identifier +type DictId = EvId -- A dictionary variable + +-- | Implicit parameter Identifier +type IpId = EvId -- A term-level implicit parameter + +-- | Equality Variable +type EqVar = EvId -- Boxed equality evidence +type JoinId = Id -- A join variable + +-- | Type or Coercion Variable +type TyCoVar = Id -- Type, *or* coercion variable + -- predicate: isTyCoVar + + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +type InVar = Var +type InTyVar = TyVar +type InCoVar = CoVar +type InId = Id +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = CoVar +type OutId = Id + + + +{- Note [Evidence: EvIds and CoVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An EvId (evidence Id) is a term-level evidence variable + (dictionary, implicit parameter, or equality). Could be boxed or unboxed. + +* DictId, IpId, and EqVar are synonyms when we know what kind of + evidence we are talking about. For example, an EqVar has type (t1 ~ t2). + +* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) + +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are used to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - TKVar to mean kind or type variables + - TypeVar to mean type variables only + - KindVar to mean kind variables + + +************************************************************************ +* * +\subsection{The main data type declarations} +* * +************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. +-} + +-- | Variable +-- +-- Essentially a typed 'Name', that may also contain some additional information +-- about the 'Var' and its use sites. +data Var + = TyVar { -- Type and kind variables + -- see Note [Kind and type variables] + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + -- ^ Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question + } + + | TcTyVar { -- Used only during type inference + -- Used for kind variables during + -- inference, as well + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Kind, + tc_tv_details :: TcTyVarDetails + } + + | Id { + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Type, + idScope :: IdScope, + id_details :: IdDetails, -- Stable, doesn't change + id_info :: IdInfo } -- Unstable, updated by simplifier + +-- | Identifier Scope +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag -- See Note [ExportFlag on binders] + = NotExported -- ^ Not exported: may be discarded as dead code. + | Exported -- ^ Exported: kept alive + +{- Note [ExportFlag on binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An ExportFlag of "Exported" on a top-level binder says "keep this +binding alive; do not drop it as dead code". This transitively +keeps alive all the other top-level bindings that this binding refers +to. This property is persisted all the way down the pipeline, so that +the binding will be compiled all the way to object code, and its +symbols will appear in the linker symbol table. + +However, note that this use of "exported" is quite different to the +export list on a Haskell module. Setting the ExportFlag on an Id does +/not/ mean that if you import the module (in Haskell source code) you +will see this Id. Of course, things that appear in the export list +of the source Haskell module do indeed have their ExportFlag set. +But many other things, such as dictionary functions, are kept alive +by having their ExportFlag set, even though they are not exported +in the source-code sense. + +We should probably use a different term for ExportFlag, like +KeepAlive. + +Note [GlobalId/LocalId] +~~~~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + * never treated as a candidate by the free-variable finder; + it's a constant! + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + * always treated as a candidate by the free-variable finder + +After CoreTidy, top-level LocalIds are turned into GlobalIds +-} + +instance Outputable Var where + ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> + getPprStyle $ \ppr_style -> + if | debugStyle ppr_style && (not supp_var_kinds) + -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> + dcolon <+> pprKind (tyVarKind var)) + | otherwise + -> ppr (varName var) <> ppr_debug var ppr_style + +ppr_debug :: Var -> PprStyle -> SDoc +ppr_debug (TyVar {}) sty + | debugStyle sty = brackets (text "tv") +ppr_debug (TcTyVar {tc_tv_details = d}) sty + | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) +ppr_debug (Id { idScope = s, id_details = d }) sty + | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) +ppr_debug _ _ = empty + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = text "gid" +ppr_id_scope (LocalId Exported) = text "lidx" +ppr_id_scope (LocalId NotExported) = text "lid" + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a == realUnique b + +instance Ord Var where + a <= b = realUnique a <= realUnique b + a < b = realUnique a < realUnique b + a >= b = realUnique a >= realUnique b + a > b = realUnique a > realUnique b + a `compare` b = a `nonDetCmpVar` b + +-- | Compare Vars by their Uniques. +-- This is what Ord Var does, provided here to make it explicit at the +-- call-site that it can introduce non-determinism. +-- See Note [Unique Determinism] +nonDetCmpVar :: Var -> Var -> Ordering +nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" + +instance HasOccName Var where + occName = nameOccName . varName + +varUnique :: Var -> Unique +varUnique var = mkUniqueGrimily (realUnique var) + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = getKey uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getKey (getUnique new_name), + varName = new_name } + +setVarType :: Id -> Type -> Id +setVarType id ty = id { varType = ty } + +updateVarType :: (Type -> Type) -> Id -> Id +updateVarType f id = id { varType = f (varType id) } + +updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id +updateVarTypeM f id = do { ty' <- f (varType id) + ; return (id { varType = ty' }) } + +{- ********************************************************************* +* * +* ArgFlag +* * +********************************************************************* -} + +-- | Argument Flag +-- +-- Is something required to appear in source Haskell ('Required'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Inferred')? +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep +data ArgFlag = Inferred | Specified | Required + deriving (Eq, Ord, Data) + -- (<) on ArgFlag means "is less visible than" + +-- | Does this 'ArgFlag' classify an argument that is written in Haskell? +isVisibleArgFlag :: ArgFlag -> Bool +isVisibleArgFlag Required = True +isVisibleArgFlag _ = False + +-- | Does this 'ArgFlag' classify an argument that is not written in Haskell? +isInvisibleArgFlag :: ArgFlag -> Bool +isInvisibleArgFlag = not . isVisibleArgFlag + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +sameVis :: ArgFlag -> ArgFlag -> Bool +sameVis Required Required = True +sameVis Required _ = False +sameVis _ Required = False +sameVis _ _ = True + +instance Outputable ArgFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Binary ArgFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +-- | The non-dependent version of 'ArgFlag'. + +-- Appears here partly so that it's together with its friend ArgFlag, +-- but also because it is used in IfaceType, rather early in the +-- compilation chain +-- See Note [AnonArgFlag vs. ForallVisFlag] +data AnonArgFlag + = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. + -- The argument is visible in source code. + | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. + -- The argument is invisible in source code. + deriving (Eq, Ord, Data) + +instance Outputable AnonArgFlag where + ppr VisArg = text "[vis]" + ppr InvisArg = text "[invis]" + +instance Binary AnonArgFlag where + put_ bh VisArg = putByte bh 0 + put_ bh InvisArg = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return VisArg + _ -> return InvisArg + +-- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible +-- (e.g., @forall a b -> {...}@, with an arrow)? + +-- See Note [AnonArgFlag vs. ForallVisFlag] +data ForallVisFlag + = ForallVis -- ^ A visible @forall@ (with an arrow) + | ForallInvis -- ^ An invisible @forall@ (with a dot) + deriving (Eq, Ord, Data) + +instance Outputable ForallVisFlag where + ppr f = text $ case f of + ForallVis -> "ForallVis" + ForallInvis -> "ForallInvis" + +-- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. +argToForallVisFlag :: ArgFlag -> ForallVisFlag +argToForallVisFlag Required = ForallVis +argToForallVisFlag Specified = ForallInvis +argToForallVisFlag Inferred = ForallInvis + +{- +Note [AnonArgFlag vs. ForallVisFlag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The AnonArgFlag and ForallVisFlag data types are quite similar at a first +glance: + + data AnonArgFlag = VisArg | InvisArg + data ForallVisFlag = ForallVis | ForallInvis + +Both data types keep track of visibility of some sort. AnonArgFlag tracks +whether a FunTy has a visible argument (->) or an invisible predicate argument +(=>). ForallVisFlag tracks whether a `forall` quantifier is visible +(forall a -> {...}) or invisible (forall a. {...}). + +Given their similarities, it's tempting to want to combine these two data types +into one, but they actually represent distinct concepts. AnonArgFlag reflects a +property of *Core* types, whereas ForallVisFlag reflects a property of the GHC +AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag +is all about surface syntax. Therefore, they are kept as separate data types. +-} + +{- ********************************************************************* +* * +* VarBndr, TyCoVarBinder +* * +********************************************************************* -} + +-- Variable Binder +-- +-- VarBndr is polymorphic in both var and visibility fields. +-- Currently there are six different uses of 'VarBndr': +-- * Var.TyVarBinder = VarBndr TyVar ArgFlag +-- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +-- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis +-- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +-- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +-- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +data VarBndr var argf = Bndr var argf + deriving( Data ) + +-- | Variable Binder +-- +-- A 'TyCoVarBinder' is the binder of a ForAllTy +-- It's convenient to define this synonym here rather its natural +-- home in GHC.Core.TyCo.Rep, because it's used in GHC.Core.DataCon.hs-boot +-- +-- A 'TyVarBinder' is a binder with only TyVar +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag + +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v + +binderVars :: [VarBndr tv argf] -> [tv] +binderVars tvbs = map binderVar tvbs + +binderArgFlag :: VarBndr tv argf -> argf +binderArgFlag (Bndr _ argf) = argf + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv + +-- | Make a named binder +mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder +mkTyCoVarBinder vis var = Bndr var vis + +-- | Make a named binder +-- 'var' should be a type variable +mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder +mkTyVarBinder vis var + = ASSERT( isTyVar var ) + Bndr var vis + +-- | Make many named binders +mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] +mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) + +-- | Make many named binders +-- Input vars should be type variables +mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] +mkTyVarBinders vis = map (mkTyVarBinder vis) + +isTyVarBinder :: TyCoVarBinder -> Bool +isTyVarBinder (Bndr v _) = isTyVar v + +instance Outputable tv => Outputable (VarBndr tv ArgFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) + +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } + + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } + +instance NamedThing tv => NamedThing (VarBndr tv flag) where + getName (Bndr tv _) = getName tv + +{- +************************************************************************ +* * +* Type and kind variables * +* * +************************************************************************ +-} + +tyVarName :: TyVar -> Name +tyVarName = varName + +tyVarKind :: TyVar -> Kind +tyVarKind = varType + +setTyVarUnique :: TyVar -> Unique -> TyVar +setTyVarUnique = setVarUnique + +setTyVarName :: TyVar -> Name -> TyVar +setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } + +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = getKey (nameUnique name) + , varType = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' + TcTyVar { varName = name, + realUnique = getKey (nameUnique name), + varType = kind, + tc_tv_details = details + } + +tcTyVarDetails :: TyVar -> TcTyVarDetails +-- See Note [TcTyVars in the typechecker] in TcType +tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details +tcTyVarDetails (TyVar {}) = vanillaSkolemTv +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) + +setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar +setTcTyVarDetails tv details = tv { tc_tv_details = details } + +{- +%************************************************************************ +%* * +\subsection{Ids} +* * +************************************************************************ +-} + +idInfo :: HasDebugCallStack => Id -> IdInfo +idInfo (Id { id_info = info }) = info +idInfo other = pprPanic "idInfo" (ppr other) + +idDetails :: Id -> IdDetails +idDetails (Id { id_details = details }) = details +idDetails other = pprPanic "idDetails" (ppr other) + +-- The next three have a 'Var' suffix even though they always build +-- Ids, because Id.hs uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name ty GlobalId details info + +mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkLocalVar details name ty info + = mk_id name ty (LocalId NotExported) details info + +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name ty (LocalId Exported) details info + +mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name ty scope details info + = Id { varName = name, + realUnique = getKey (nameUnique name), + varType = ty, + idScope = scope, + id_details = details, + id_info = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { id_info = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { id_details = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) + id { idScope = LocalId NotExported } + +{- +************************************************************************ +* * +\subsection{Predicates over variables} +* * +************************************************************************ +-} + +-- | Is this a type-level (i.e., computationally irrelevant, thus erasable) +-- variable? Satisfies @isTyVar = not . isId@. +isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar _ = False + +isTcTyVar :: Var -> Bool -- True of TcTyVar only +isTcTyVar (TcTyVar {}) = True +isTcTyVar _ = False + +isTyCoVar :: Var -> Bool +isTyCoVar v = isTyVar v || isCoVar v + +-- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? +-- Satisfies @isId = not . isTyVar@. +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False + +-- | Is this a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isCoVar :: Var -> Bool +isCoVar (Id { id_details = details }) = isCoVarDetails details +isCoVar _ = False + +-- | Is this a term variable ('Id') that is /not/ a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isNonCoVarId :: Var -> Bool +isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) +isNonCoVarId _ = False + +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False + +-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar :: Var -> Bool +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False + +-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's +-- that must have a binding in this module. The converse +-- is not quite right: there are some global 'Id's that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding :: Var -> Bool +mustHaveLocalBinding var = isLocalVar var + +-- | 'isExportedIdVar' means \"don't throw this away\" +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Var.hs-boot @@ -0,0 +1,14 @@ +module GHC.Types.Var where + +import GhcPrelude () + -- We compile this module with -XNoImplicitPrelude (for some + -- reason), so if there are no imports it does not seem to + -- depend on anything. But it does! We must, for example, + -- compile GHC.Types in the ghc-prim library first. + -- So this otherwise-unnecessary import tells the build system + -- that this module depends on GhcPrelude, which ensures + -- that GHC.Type is built first. + +data ArgFlag +data AnonArgFlag +data Var diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Var/Env.hs @@ -0,0 +1,632 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Types.Var.Env ( + -- * Var, Id and TyVar environments (maps) + VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, + + -- ** Manipulating these environments + emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, + elemVarEnv, disjointVarEnv, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, + extendVarEnvList, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + plusVarEnvList, alterVarEnv, + delVarEnvList, delVarEnv, delVarEnv_Directly, + minusVarEnv, intersectsVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, + elemVarEnvByKey, lookupVarEnv_Directly, + filterVarEnv, filterVarEnv_Directly, restrictVarEnv, + partitionVarEnv, + + -- * Deterministic Var environments (maps) + DVarEnv, DIdEnv, DTyVarEnv, + + -- ** Manipulating these environments + emptyDVarEnv, mkDVarEnv, + dVarEnvElts, + extendDVarEnv, extendDVarEnv_C, + extendDVarEnvList, + lookupDVarEnv, elemDVarEnv, + isEmptyDVarEnv, foldDVarEnv, + mapDVarEnv, filterDVarEnv, + modifyDVarEnv, + alterDVarEnv, + plusDVarEnv, plusDVarEnv_C, + unitDVarEnv, + delDVarEnv, + delDVarEnvList, + minusDVarEnv, + partitionDVarEnv, + anyDVarEnv, + + -- * The InScopeSet type + InScopeSet, + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, + varSetInScope, + unsafeGetFreshLocalUnique, + + -- * The RnEnv2 type + RnEnv2, + + -- ** Operations on RnEnv2s + mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, + delBndrL, delBndrR, delBndrsL, delBndrsR, + addRnInScopeSet, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + rnEnvL, rnEnvR, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList + ) where + +import GhcPrelude +import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM + +import GHC.Types.Name.Occurrence +import GHC.Types.Name +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique +import Util +import Maybes +import Outputable + +{- +************************************************************************ +* * + In-scope sets +* * +************************************************************************ +-} + +-- | A set of variables that are in scope at some point +-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides +-- the motivation for this abstraction. +newtype InScopeSet = InScope VarSet + -- Note [Lookups in in-scope set] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We store a VarSet here, but we use this for lookups rather than just + -- membership tests. Typically the InScopeSet contains the canonical + -- version of the variable (e.g. with an informative unfolding), so this + -- lookup is useful (see, for instance, Note [In-scope set as a + -- substitution]). + +instance Outputable InScopeSet where + ppr (InScope s) = + text "InScope" <+> + braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) + -- It's OK to use nonDetEltsUniqSet here because it's + -- only for pretty printing + -- In-scope sets get big, and with -dppr-debug + -- the output is overwhelming + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet + +getInScopeVars :: InScopeSet -> VarSet +getInScopeVars (InScope vs) = vs + +mkInScopeSet :: VarSet -> InScopeSet +mkInScopeSet in_scope = InScope in_scope + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope) v + = InScope (extendVarSet in_scope v) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope) vs + = InScope $ foldl' extendVarSet in_scope vs + +extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet +extendInScopeSetSet (InScope in_scope) vs + = InScope (in_scope `unionVarSet` vs) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope + +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. +lookupInScope :: InScopeSet -> Var -> Maybe Var +lookupInScope (InScope in_scope) v = lookupVarSet in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope) uniq + = lookupVarSet_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1) (InScope s2) + = InScope (s1 `unionVarSet` s2) + +varSetInScope :: VarSet -> InScopeSet -> Bool +varSetInScope vars (InScope s1) = vars `subVarSet` s1 + +{- +Note [Local uniques] +~~~~~~~~~~~~~~~~~~~~ +Sometimes one must create conjure up a unique which is unique in a particular +context (but not necessarily globally unique). For instance, one might need to +create a fresh local identifier which does not shadow any of the locally +in-scope variables. For this we purpose we provide 'uniqAway'. + +'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' +operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To +ensure that we do not conflict with uniques allocated by future allocations +from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are +allocated into a dedicated region of the unique space (namely the X tag). + +Note that one must be quite carefully when using uniques generated in this way +since they are only locally unique. In particular, two successive calls to +'uniqAway' on the same 'InScopeSet' will produce the same unique. + -} + +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. See Note [Local uniques]. +uniqAway :: InScopeSet -> Var -> Var +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses the successor to the last derived unique +-- found in the in-scope set. +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' in_scope var + = setVarUnique var (unsafeGetFreshLocalUnique in_scope) + +-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the +-- given 'InScopeSet'. This must be used very carefully since one can very easily +-- introduce non-unique 'Unique's this way. See Note [Local uniques]. +unsafeGetFreshLocalUnique :: InScopeSet -> Unique +unsafeGetFreshLocalUnique (InScope set) + | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) + , let uniq' = mkLocalUnique uniq + , not $ uniq' `ltUnique` minLocalUnique + = incrUnique uniq' + + | otherwise + = minLocalUnique + +{- +************************************************************************ +* * + Dual renaming +* * +************************************************************************ +-} + +-- | Rename Environment 2 +-- +-- When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 +addRnInScopeSet env vs + | isEmptyVarSet vs = env + | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } + +rnInScope :: Var -> RnEnv2 -> Bool +rnInScope x env = x `elemInScopeSet` in_scope env + +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + +-- | Retrieve the left mapping +rnEnvL :: RnEnv2 -> VarEnv Var +rnEnvL = envL + +-- | Retrieve the right mapping +rnEnvR :: RnEnv2 -> VarEnv Var +rnEnvR = envR + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ +rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR + +rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but returns the new variable as well as the +-- new environment +rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- side only. +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the right +-- side only. +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- ^ Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env +inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env + +lookupRnInScope :: RnEnv2 -> Var -> Var +lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } + +rnSwap :: RnEnv2 -> RnEnv2 +-- ^ swap the meaning of left and right +rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) + = RV2 { envL = envR, envR = envL, in_scope = in_scope } + +{- +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + + +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +-- | Tidy Environment +-- +-- When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) + +mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv +mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) + +delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv +delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') + where + occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs + var_env' = var_env `delVarEnvList` vs + +{- +************************************************************************ +* * +\subsection{@VarEnv@s} +* * +************************************************************************ +-} + +-- | Variable Environment +type VarEnv elt = UniqFM elt + +-- | Identifier Environment +type IdEnv elt = VarEnv elt + +-- | Type Variable Environment +type TyVarEnv elt = VarEnv elt + +-- | Type or Coercion Variable Environment +type TyCoVarEnv elt = VarEnv elt + +-- | Coercion Variable Environment +type CoVarEnv elt = VarEnv elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +plusVarEnvList :: [VarEnv a] -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a + +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a +intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a +plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +disjointVarEnv :: VarEnv a -> VarEnv a -> Bool + +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +disjointVarEnv = disjointUFM +alterVarEnv = alterUFM +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc +extendVarEnv_Directly = addToUFM_Directly +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +plusVarEnv_CD = plusUFM_CD +plusMaybeVarEnv_C = plusMaybeUFM_C +delVarEnvList = delListFromUFM +delVarEnv = delFromUFM +minusVarEnv = minusUFM +intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) +plusVarEnv = plusUFM +plusVarEnvList = plusUFMList +lookupVarEnv = lookupUFM +filterVarEnv = filterUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +mkVarEnv_Directly= listToUFM_Directly +emptyVarEnv = emptyUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly +delVarEnv_Directly = delFromUFM_Directly +partitionVarEnv = partitionUFM + +restrictVarEnv env vs = filterVarEnv_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" + +{- +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. +-} + +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) + +-- Deterministic VarEnv +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarEnv. + +-- | Deterministic Variable Environment +type DVarEnv elt = UniqDFM elt + +-- | Deterministic Identifier Environment +type DIdEnv elt = DVarEnv elt + +-- | Deterministic Type Variable Environment +type DTyVarEnv elt = DVarEnv elt + +emptyDVarEnv :: DVarEnv a +emptyDVarEnv = emptyUDFM + +dVarEnvElts :: DVarEnv a -> [a] +dVarEnvElts = eltsUDFM + +mkDVarEnv :: [(Var, a)] -> DVarEnv a +mkDVarEnv = listToUDFM + +extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv = addToUDFM + +minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a +minusDVarEnv = minusUDFM + +lookupDVarEnv :: DVarEnv a -> Var -> Maybe a +lookupDVarEnv = lookupUDFM + +foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +foldDVarEnv = foldUDFM + +mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b +mapDVarEnv = mapUDFM + +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + +alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a +alterDVarEnv = alterUDFM + +plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv = plusUDFM + +plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv_C = plusUDFM_C + +unitDVarEnv :: Var -> a -> DVarEnv a +unitDVarEnv = unitUDFM + +delDVarEnv :: DVarEnv a -> Var -> DVarEnv a +delDVarEnv = delFromUDFM + +delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a +delDVarEnvList = delListFromUDFM + +isEmptyDVarEnv :: DVarEnv a -> Bool +isEmptyDVarEnv = isNullUDFM + +elemDVarEnv :: Var -> DVarEnv a -> Bool +elemDVarEnv = elemUDFM + +extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv_C = addToUDFM_C + +modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a +modifyDVarEnv mangle_fn env key + = case (lookupDVarEnv env key) of + Nothing -> env + Just xx -> extendDVarEnv env key (mangle_fn xx) + +partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) +partitionDVarEnv = partitionUDFM + +extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a +extendDVarEnvList = addListToUDFM + +anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool +anyDVarEnv = anyUDFM diff --git a/compiler/GHC/Types/Var/Set.hs b/compiler/GHC/Types/Var/Set.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Var/Set.hs @@ -0,0 +1,354 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module GHC.Types.Var.Set ( + -- * Var, Id and TyVar set types + VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, + + -- ** Manipulating these sets + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, + elemVarSet, subVarSet, + unionVarSet, unionVarSets, mapUnionVarSet, + intersectVarSet, intersectsVarSet, disjointVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, filterVarSet, mapVarSet, + anyVarSet, allVarSet, + transCloVarSet, fixVarSet, + lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, + sizeVarSet, seqVarSet, + elemVarSetByKey, partitionVarSet, + pluralVarSet, pprVarSet, + nonDetFoldVarSet, + + -- * Deterministic Var set types + DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, + + -- ** Manipulating these sets + emptyDVarSet, unitDVarSet, mkDVarSet, + extendDVarSet, extendDVarSetList, + elemDVarSet, dVarSetElems, subDVarSet, + unionDVarSet, unionDVarSets, mapUnionDVarSet, + intersectDVarSet, dVarSetIntersectVarSet, + intersectsDVarSet, disjointDVarSet, + isEmptyDVarSet, delDVarSet, delDVarSetList, + minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, + dVarSetMinusVarSet, anyDVarSet, allDVarSet, + transCloDVarSet, + sizeDVarSet, seqDVarSet, + partitionDVarSet, + dVarSetToVarSet, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Var ( Var, TyVar, CoVar, TyCoVar, Id ) +import GHC.Types.Unique +import GHC.Types.Name ( Name ) +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM( disjointUFM, pluralUFM, pprUFM ) +import GHC.Types.Unique.DFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) +import Outputable (SDoc) + +-- | A non-deterministic Variable Set +-- +-- A non-deterministic set of variables. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not +-- deterministic and why it matters. Use DVarSet if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code, for example when abstracting variables. +type VarSet = UniqSet Var + +-- | Identifier Set +type IdSet = UniqSet Id + +-- | Type Variable Set +type TyVarSet = UniqSet TyVar + +-- | Coercion Variable Set +type CoVarSet = UniqSet CoVar + +-- | Type or Coercion Variable Set +type TyCoVarSet = UniqSet TyCoVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet + +mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet +-- ^ map the function over the list, and union the results + +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +lookupVarSetByName :: VarSet -> Name -> Maybe Var +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; + -- ditto disjointVarSet, subVarSet + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +lookupVarSet_Directly = lookupUniqSet_Directly +lookupVarSet = lookupUniqSet +lookupVarSetByName = lookupUniqSet +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +delVarSetByKey = delOneFromUniqSet_Directly +elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet + +mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs + +-- See comments with type signatures +intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) +disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) +subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) + +anyVarSet :: (Var -> Bool) -> VarSet -> Bool +anyVarSet = uniqSetAny + +allVarSet :: (Var -> Bool) -> VarSet -> Bool +allVarSet = uniqSetAll + +mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapVarSet = mapUniqSet + +nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +nonDetFoldVarSet = nonDetFoldUniqSet + +fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set + -> VarSet -> VarSet +-- (fixVarSet f s) repeatedly applies f to the set s, +-- until it reaches a fixed point. +fixVarSet fn vars + | new_vars `subVarSet` vars = vars + | otherwise = fixVarSet fn new_vars + where + new_vars = fn vars + +transCloVarSet :: (VarSet -> VarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> VarSet -> VarSet +-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- Use fixVarSet if the function needs to see the whole set all at once +transCloVarSet fn seeds + = go seeds seeds + where + go :: VarSet -- Accumulating result + -> VarSet -- Work-list; un-processed subset of accumulating result + -> VarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyVarSet new_vs = acc + | otherwise = go (acc `unionVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusVarSet` acc + +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralVarSet :: VarSet -> SDoc +pluralVarSet = pluralUFM . getUniqSet + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +-- Passing a list to the pretty-printing function allows the caller +-- to decide on the order of Vars (eg. toposort them) without them having +-- to use nonDetEltsUFM at the call site. This prevents from let-binding +-- non-deterministically ordered lists and reusing them where determinism +-- matters. +pprVarSet :: VarSet -- ^ The things to be pretty printed + -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the + -- elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprVarSet = pprUFM . getUniqSet + +-- Deterministic VarSet +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarSet. + +-- | Deterministic Variable Set +type DVarSet = UniqDSet Var + +-- | Deterministic Identifier Set +type DIdSet = UniqDSet Id + +-- | Deterministic Type Variable Set +type DTyVarSet = UniqDSet TyVar + +-- | Deterministic Type or Coercion Variable Set +type DTyCoVarSet = UniqDSet TyCoVar + +emptyDVarSet :: DVarSet +emptyDVarSet = emptyUniqDSet + +unitDVarSet :: Var -> DVarSet +unitDVarSet = unitUniqDSet + +mkDVarSet :: [Var] -> DVarSet +mkDVarSet = mkUniqDSet + +-- The new element always goes to the right of existing ones. +extendDVarSet :: DVarSet -> Var -> DVarSet +extendDVarSet = addOneToUniqDSet + +elemDVarSet :: Var -> DVarSet -> Bool +elemDVarSet = elementOfUniqDSet + +dVarSetElems :: DVarSet -> [Var] +dVarSetElems = uniqDSetToList + +subDVarSet :: DVarSet -> DVarSet -> Bool +subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) + +unionDVarSet :: DVarSet -> DVarSet -> DVarSet +unionDVarSet = unionUniqDSets + +unionDVarSets :: [DVarSet] -> DVarSet +unionDVarSets = unionManyUniqDSets + +-- | Map the function over the list, and union the results +mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet +mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs + +intersectDVarSet :: DVarSet -> DVarSet -> DVarSet +intersectDVarSet = intersectUniqDSets + +dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetIntersectVarSet = uniqDSetIntersectUniqSet + +-- | True if empty intersection +disjointDVarSet :: DVarSet -> DVarSet -> Bool +disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) + +-- | True if non-empty intersection +intersectsDVarSet :: DVarSet -> DVarSet -> Bool +intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) + +isEmptyDVarSet :: DVarSet -> Bool +isEmptyDVarSet = isEmptyUniqDSet + +delDVarSet :: DVarSet -> Var -> DVarSet +delDVarSet = delOneFromUniqDSet + +minusDVarSet :: DVarSet -> DVarSet -> DVarSet +minusDVarSet = minusUniqDSet + +dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetMinusVarSet = uniqDSetMinusUniqSet + +foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a +foldDVarSet = foldUniqDSet + +anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool +anyDVarSet p = anyUDFM p . getUniqDSet + +allDVarSet :: (Var -> Bool) -> DVarSet -> Bool +allDVarSet p = allUDFM p . getUniqDSet + +mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapDVarSet = mapUniqDSet + +filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet +filterDVarSet = filterUniqDSet + +sizeDVarSet :: DVarSet -> Int +sizeDVarSet = sizeUniqDSet + +-- | Partition DVarSet according to the predicate given +partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) +partitionDVarSet = partitionUniqDSet + +-- | Delete a list of variables from DVarSet +delDVarSetList :: DVarSet -> [Var] -> DVarSet +delDVarSetList = delListFromUniqDSet + +seqDVarSet :: DVarSet -> () +seqDVarSet s = sizeDVarSet s `seq` () + +-- | Add a list of variables to DVarSet +extendDVarSetList :: DVarSet -> [Var] -> DVarSet +extendDVarSetList = addListToUniqDSet + +-- | Convert a DVarSet to a VarSet by forgetting the order of insertion +dVarSetToVarSet :: DVarSet -> VarSet +dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet + +-- | transCloVarSet for DVarSet +transCloDVarSet :: (DVarSet -> DVarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> DVarSet -> DVarSet +-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +transCloDVarSet fn seeds + = go seeds seeds + where + go :: DVarSet -- Accumulating result + -> DVarSet -- Work-list; un-processed subset of accumulating result + -> DVarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyDVarSet new_vs = acc + | otherwise = go (acc `unionDVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusDVarSet` acc diff --git a/compiler/GHC/Utils/Lexeme.hs b/compiler/GHC/Utils/Lexeme.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Utils/Lexeme.hs @@ -0,0 +1,240 @@ +-- (c) The GHC Team +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- There is considerable overlap between the logic here and the logic +-- in Lexer.x, but sadly there seems to be no way to merge them. + +module GHC.Utils.Lexeme ( + -- * Lexical characteristics of Haskell names + + -- | Use these functions to figure what kind of name a 'FastString' + -- represents; these functions do /not/ check that the identifier + -- is valid. + + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId, + + -- * Validating identifiers + + -- | These functions (working over plain old 'String's) check + -- to make sure that the identifier is valid. + okVarOcc, okConOcc, okTcOcc, + okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc + + -- Some of the exports above are not used within GHC, but may + -- be of value to GHC API users. + + ) where + +import GhcPrelude + +import FastString + +import Data.Char +import qualified Data.Set as Set + +import GHC.Lexeme + +{- + +************************************************************************ +* * + Lexical categories +* * +************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +Note [Classification of generated names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some names generated for internal use can show up in debugging output, +e.g. when using -ddump-simpl. These generated names start with a $ +but should still be pretty-printed using prefix notation. We make sure +this is the case in isLexVarSym by only classifying a name as a symbol +if all its characters are symbols, not just its first one. +-} + +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- +isLexConId cs -- Prefix type or data constructors + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == (fsLit "[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFS cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == (fsLit "->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise + = case (if nullFS fs then [] else unpackFS fs) of + [] -> False + (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] + +{- + +************************************************************************ +* * + Detecting valid names for Template Haskell +* * +************************************************************************ + +-} + +---------------------- +-- External interface +---------------------- + +-- | Is this an acceptable variable name? +okVarOcc :: String -> Bool +okVarOcc str@(c:_) + | startsVarId c + = okVarIdOcc str + | startsVarSym c + = okVarSymOcc str +okVarOcc _ = False + +-- | Is this an acceptable constructor name? +okConOcc :: String -> Bool +okConOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | str == "[]" + = True +okConOcc _ = False + +-- | Is this an acceptable type name? +okTcOcc :: String -> Bool +okTcOcc "[]" = True +okTcOcc "->" = True +okTcOcc "~" = True +okTcOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | startsVarSym c + = okVarSymOcc str +okTcOcc _ = False + +-- | Is this an acceptable alphanumeric variable name, assuming it starts +-- with an acceptable letter? +okVarIdOcc :: String -> Bool +okVarIdOcc str = okIdOcc str && + -- admit "_" as a valid identifier. Required to support typed + -- holes in Template Haskell. See #10267 + (str == "_" || not (str `Set.member` reservedIds)) + +-- | Is this an acceptable symbolic variable name, assuming it starts +-- with an acceptable character? +okVarSymOcc :: String -> Bool +okVarSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) && + not (isDashes str) + +-- | Is this an acceptable alphanumeric constructor name, assuming it +-- starts with an acceptable letter? +okConIdOcc :: String -> Bool +okConIdOcc str = okIdOcc str || + is_tuple_name1 True str || + -- Is it a boxed tuple... + is_tuple_name1 False str || + -- ...or an unboxed tuple (#12407)... + is_sum_name1 str + -- ...or an unboxed sum (#12514)? + where + -- check for tuple name, starting at the beginning + is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest + is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest + is_tuple_name1 _ _ = False + + -- check for tuple tail + is_tuple_name2 True ")" = True + is_tuple_name2 False "#)" = True + is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest + is_tuple_name2 boxed (ws : rest) + | isSpace ws = is_tuple_name2 boxed rest + is_tuple_name2 _ _ = False + + -- check for sum name, starting at the beginning + is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest + is_sum_name1 _ = False + + -- check for sum tail, only allowing at most one underscore + is_sum_name2 _ "#)" = True + is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest + is_sum_name2 False ('_' : rest) = is_sum_name2 True rest + is_sum_name2 underscore (ws : rest) + | isSpace ws = is_sum_name2 underscore rest + is_sum_name2 _ _ = False + +-- | Is this an acceptable symbolic constructor name, assuming it +-- starts with an acceptable character? +okConSymOcc :: String -> Bool +okConSymOcc ":" = True +okConSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) + +---------------------- +-- Internal functions +---------------------- + +-- | Is this string an acceptable id, possibly with a suffix of hashes, +-- but not worrying about case or clashing with reserved words? +okIdOcc :: String -> Bool +okIdOcc str + = let hashes = dropWhile okIdChar str in + all (== '#') hashes -- -XMagicHash allows a suffix of hashes + -- of course, `all` says "True" to an empty list + +-- | Is this character acceptable in an identifier (after the first letter)? +-- See alexGetByte in Lexer.x +okIdChar :: Char -> Bool +okIdChar c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + TitlecaseLetter -> True + ModifierLetter -> True -- See #10196 + OtherLetter -> True -- See #1103 + NonSpacingMark -> True -- See #7650 + DecimalNumber -> True + OtherNumber -> True -- See #4373 + _ -> c == '\'' || c == '_' + +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. +reservedIds :: Set.Set String +reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" + , "do", "else", "foreign", "if", "import", "in" + , "infix", "infixl", "infixr", "instance", "let" + , "module", "newtype", "of", "then", "type", "where" + , "_" ] + +-- | All reserved operators. Taken from section 2.4 of the 2010 Report. +reservedOps :: Set.Set String +reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" + , "@", "~", "=>" ] + +-- | Does this string contain only dashes and has at least 2 of them? +isDashes :: String -> Bool +isDashes ('-' : '-' : rest) = all (== '-') rest +isDashes _ = False diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs deleted file mode 100644 --- a/compiler/basicTypes/Avail.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} --- --- (c) The University of Glasgow --- - -#include "HsVersions.h" - -module Avail ( - Avails, - AvailInfo(..), - avail, - availsToNameSet, - availsToNameSetWithSelectors, - availsToNameEnv, - availName, availNames, availNonFldNames, - availNamesWithSelectors, - availFlds, - availsNamesWithOccs, - availNamesWithOccs, - stableAvailCmp, - plusAvail, - trimAvail, - filterAvail, - filterAvails, - nubAvails - - - ) where - -import GhcPrelude - -import Name -import NameEnv -import NameSet - -import FieldLabel -import Binary -import ListSetOps -import Outputable -import Util - -import Data.Data ( Data ) -import Data.List ( find ) -import Data.Function - --- ----------------------------------------------------------------------------- --- The AvailInfo type - --- | Records what things are \"available\", i.e. in scope -data AvailInfo - - -- | An ordinary identifier in scope - = Avail Name - - -- | A type or class in scope - -- - -- The __AvailTC Invariant__: If the type or class is itself to be in scope, - -- it must be /first/ in this list. Thus, typically: - -- - -- > AvailTC Eq [Eq, ==, \/=] [] - | AvailTC - Name -- ^ The name of the type or class - [Name] -- ^ The available pieces of type or class, - -- excluding field selectors. - [FieldLabel] -- ^ The record fields of the type - -- (see Note [Representing fields in AvailInfo]). - - deriving ( Eq -- ^ Used when deciding if the interface has changed - , Data ) - --- | A collection of 'AvailInfo' - several things that are \"available\" -type Avails = [AvailInfo] - -{- -Note [Representing fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -XDuplicateRecordFields is disabled (the normal case), a -datatype like - - data T = MkT { foo :: Int } - -gives rise to the AvailInfo - - AvailTC T [T, MkT] [FieldLabel "foo" False foo] - -whereas if -XDuplicateRecordFields is enabled it gives - - AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] - -since the label does not match the selector name. - -The labels in a field list are not necessarily unique: -data families allow the same parent (the family tycon) to have -multiple distinct fields with the same label. For example, - - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool} - -gives rise to - - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" True $sel:foo:MkFBool ] - -Moreover, note that the flIsOverloaded flag need not be the same for -all the elements of the list. In the example above, this occurs if -the two data instances are defined in different modules, one with -`-XDuplicateRecordFields` enabled and one with it disabled. Thus it -is possible to have - - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" False foo ] - -If the two data instances are defined in different modules, both -without `-XDuplicateRecordFields`, it will be impossible to export -them from the same module (even with `-XDuplicateRecordfields` -enabled), because they would be represented identically. The -workaround here is to enable `-XDuplicateRecordFields` on the defining -modules. --} - --- | Compare lexicographically -stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 -stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = - (n `stableNameCmp` m) `thenCmp` - (cmpList stableNameCmp ns ms) `thenCmp` - (cmpList (stableNameCmp `on` flSelector) nfs mfs) -stableAvailCmp (AvailTC {}) (Avail {}) = GT - -avail :: Name -> AvailInfo -avail n = Avail n - --- ----------------------------------------------------------------------------- --- Operations on AvailInfo - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNames avail) - -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet -availsToNameSetWithSelectors avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNamesWithSelectors avail) - -availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo -availsToNameEnv avails = foldr add emptyNameEnv avails - where add avail env = extendNameEnvList env - (zip (availNames avail) (repeat avail)) - --- | Just the main name made available, i.e. not the available pieces --- of type or class brought into scope by the 'GenAvailInfo' -availName :: AvailInfo -> Name -availName (Avail n) = n -availName (AvailTC n _ _) = n - --- | All names made available by the availability information (excluding overloaded selectors) -availNames :: AvailInfo -> [Name] -availNames (Avail n) = [n] -availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] - --- | All names made available by the availability information (including overloaded selectors) -availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail n) = [n] -availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs - --- | Names for non-fields made available by the availability information -availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail n) = [n] -availNonFldNames (AvailTC _ ns _) = ns - --- | Fields made available by the availability information -availFlds :: AvailInfo -> [FieldLabel] -availFlds (AvailTC _ _ fs) = fs -availFlds _ = [] - -availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] -availsNamesWithOccs = concatMap availNamesWithOccs - --- | 'Name's made available by the availability information, paired with --- the 'OccName' used to refer to each one. --- --- When @DuplicateRecordFields@ is in use, the 'Name' may be the --- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the --- 'OccName' will be the label of the field (e.g. @foo@). --- --- See Note [Representing fields in AvailInfo]. -availNamesWithOccs :: AvailInfo -> [(Name, OccName)] -availNamesWithOccs (Avail n) = [(n, nameOccName n)] -availNamesWithOccs (AvailTC _ ns fs) - = [ (n, nameOccName n) | n <- ns ] ++ - [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] - --- ----------------------------------------------------------------------------- --- Utility - -plusAvail :: AvailInfo -> AvailInfo -> AvailInfo -plusAvail a1 a2 - | debugIsOn && availName a1 /= availName a2 - = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) -plusAvail a1@(Avail {}) (Avail {}) = a1 -plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 -plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 -plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) - = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first - (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (fs1 `unionLists` fs2) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (fs1 `unionLists` fs2) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (fs1 `unionLists` fs2) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) - (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) - = AvailTC n1 ss1 (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) - = AvailTC n1 ss2 (fs1 `unionLists` fs2) -plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) - --- | trims an 'AvailInfo' to keep only a single name -trimAvail :: AvailInfo -> Name -> AvailInfo -trimAvail (Avail n) _ = Avail n -trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of - Just x -> AvailTC n [] [x] - Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] - --- | filters 'AvailInfo's by the given predicate -filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] -filterAvails keep avails = foldr (filterAvail keep) [] avails - --- | filters an 'AvailInfo' by the given predicate -filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] -filterAvail keep ie rest = - case ie of - Avail n | keep n -> ie : rest - | otherwise -> rest - AvailTC tc ns fs -> - let ns' = filter keep ns - fs' = filter (keep . flSelector) fs in - if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest - - --- | Combines 'AvailInfo's from the same family --- 'avails' may have several items with the same availName --- E.g import Ix( Ix(..), index ) --- will give Ix(Ix,index,range) and Ix(index) --- We want to combine these; addAvail does that -nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) - where - add env avail = extendNameEnv_C plusAvail env (availName avail) avail - --- ----------------------------------------------------------------------------- --- Printing - -instance Outputable AvailInfo where - ppr = pprAvail - -pprAvail :: AvailInfo -> SDoc -pprAvail (Avail n) - = ppr n -pprAvail (AvailTC n ns fs) - = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi - , fsep (punctuate comma (map (ppr . flLabel) fs))]) - -instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac ad) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - ad <- get bh - return (AvailTC ab ac ad) diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs deleted file mode 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ /dev/null @@ -1,1736 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 - -\section[BasicTypes]{Miscellaneous types} - -This module defines a miscellaneously collection of very simple -types that - -\begin{itemize} -\item have no other obvious home -\item don't depend on any other complicated types -\item are used in more than one "part" of the compiler -\end{itemize} --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module BasicTypes( - Version, bumpVersion, initialVersion, - - LeftOrRight(..), - pickLR, - - ConTag, ConTagZ, fIRST_TAG, - - Arity, RepArity, JoinArity, - - Alignment, mkAlignment, alignmentOf, alignmentBytes, - - PromotionFlag(..), isPromoted, - FunctionOrData(..), - - WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), - - Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, minPrecedence, - negateFixity, funTyFixity, - compareFixity, - LexicalFixity(..), - - RecFlag(..), isRec, isNonRec, boolToRecFlag, - Origin(..), isGenerated, - - RuleName, pprRuleName, - - TopLevelFlag(..), isTopLevel, isNotTopLevel, - - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, - - Boxity(..), isBoxed, - - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, - maybeParen, - - TupleSort(..), tupleSortBoxity, boxityTupleSort, - tupleParens, - - sumParens, pprAlternative, - - -- ** The OneShotInfo type - OneShotInfo(..), - noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, - bestOneShot, worstOneShot, - - OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, - strongLoopBreaker, weakLoopBreaker, - - InsideLam(..), - OneBranch(..), - InterestingCxt(..), - TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, - isAlwaysTailCalled, - - EP(..), - - DefMethSpec(..), - SwapFlag(..), flipSwap, unSwap, isSwapped, - - CompilerPhase(..), PhaseNum, - - Activation(..), isActive, isActiveIn, competesWith, - isNeverActive, isAlwaysActive, isEarlyActive, - activeAfterInitial, activeDuringFinal, - - RuleMatchInfo(..), isConLike, isFunLike, - InlineSpec(..), noUserInlineSpec, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, - neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, - isInlinePragma, isInlinablePragma, isAnyInlinePragma, - inlinePragmaSpec, inlinePragmaSat, - inlinePragmaActivation, inlinePragmaRuleMatchInfo, - setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - pprInline, pprInlineDebug, - - SuccessFlag(..), succeeded, failed, successIf, - - IntegralLit(..), FractionalLit(..), - negateIntegralLit, negateFractionalLit, - mkIntegralLit, mkFractionalLit, - integralFractionalLit, - - SourceText(..), pprWithSourceText, - - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, - - SpliceExplicitFlag(..), - - TypeOrKind(..), isTypeLevel, isKindLevel - ) where - -import GhcPrelude - -import FastString -import Outputable -import SrcLoc ( Located,unLoc ) -import Data.Data hiding (Fixity, Prefix, Infix) -import Data.Function (on) -import Data.Bits -import qualified Data.Semigroup as Semi - -{- -************************************************************************ -* * - Binary choice -* * -************************************************************************ --} - -data LeftOrRight = CLeft | CRight - deriving( Eq, Data ) - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - -instance Outputable LeftOrRight where - ppr CLeft = text "Left" - ppr CRight = text "Right" - -{- -************************************************************************ -* * -\subsection[Arity]{Arity} -* * -************************************************************************ --} - --- | The number of value arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has arity 0 --- \x -> fib x has arity 1 --- See also Note [Definition of arity] in GHC.Core.Arity -type Arity = Int - --- | Representation Arity --- --- The number of represented arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has representation arity 0 --- \x -> fib x has representation arity 1 --- \(# x, y #) -> fib (x + y) has representation arity 2 -type RepArity = Int - --- | The number of arguments that a join point takes. Unlike the arity of a --- function, this is a purely syntactic property and is fixed when the join --- point is created (or converted from a value). Both type and value arguments --- are counted. -type JoinArity = Int - -{- -************************************************************************ -* * - Constructor tags -* * -************************************************************************ --} - --- | Constructor Tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - --- | A *zero-indexed* constructor tag -type ConTagZ = Int - -fIRST_TAG :: ConTag --- ^ Tags are allocated from here for real constructors --- or for superclass selectors -fIRST_TAG = 1 - -{- -************************************************************************ -* * -\subsection[Alignment]{Alignment} -* * -************************************************************************ --} - --- | A power-of-two alignment -newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) - --- Builds an alignment, throws on non power of 2 input. This is not --- ideal, but convenient for internal use and better then silently --- passing incorrect data. -mkAlignment :: Int -> Alignment -mkAlignment n - | n == 1 = Alignment 1 - | n == 2 = Alignment 2 - | n == 4 = Alignment 4 - | n == 8 = Alignment 8 - | n == 16 = Alignment 16 - | n == 32 = Alignment 32 - | n == 64 = Alignment 64 - | n == 128 = Alignment 128 - | n == 256 = Alignment 256 - | n == 512 = Alignment 512 - | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" - --- Calculates an alignment of a number. x is aligned at N bytes means --- the remainder from x / N is zero. Currently, interested in N <= 8, --- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX --- context. -alignmentOf :: Int -> Alignment -alignmentOf x = case x .&. 7 of - 0 -> Alignment 8 - 4 -> Alignment 4 - 2 -> Alignment 2 - _ -> Alignment 1 - -instance Outputable Alignment where - ppr (Alignment m) = ppr m -{- -************************************************************************ -* * - One-shot information -* * -************************************************************************ --} - --- | If the 'Id' is a lambda-bound variable then it may have lambda-bound --- variable info. Sometimes we know whether the lambda binding this variable --- is a \"one-shot\" lambda; that is, whether it is applied at most once. --- --- This information may be useful in optimisation, as computations may --- safely be floated inside such a lambda without risk of duplicating --- work. -data OneShotInfo - = NoOneShotInfo -- ^ No information - | OneShotLam -- ^ The lambda is applied at most once. - deriving (Eq) - --- | It is always safe to assume that an 'Id' has no lambda-bound variable information -noOneShotInfo :: OneShotInfo -noOneShotInfo = NoOneShotInfo - -isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool -isOneShotInfo OneShotLam = True -isOneShotInfo _ = False - -hasNoOneShotInfo NoOneShotInfo = True -hasNoOneShotInfo _ = False - -worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo -worstOneShot NoOneShotInfo _ = NoOneShotInfo -worstOneShot OneShotLam os = os - -bestOneShot NoOneShotInfo os = os -bestOneShot OneShotLam _ = OneShotLam - -pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty -pprOneShotInfo OneShotLam = text "OneShot" - -instance Outputable OneShotInfo where - ppr = pprOneShotInfo - -{- -************************************************************************ -* * - Swap flag -* * -************************************************************************ --} - -data SwapFlag - = NotSwapped -- Args are: actual, expected - | IsSwapped -- Args are: expected, actual - -instance Outputable SwapFlag where - ppr IsSwapped = text "Is-swapped" - ppr NotSwapped = text "Not-swapped" - -flipSwap :: SwapFlag -> SwapFlag -flipSwap IsSwapped = NotSwapped -flipSwap NotSwapped = IsSwapped - -isSwapped :: SwapFlag -> Bool -isSwapped IsSwapped = True -isSwapped NotSwapped = False - -unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b -unSwap NotSwapped f a b = f a b -unSwap IsSwapped f a b = f b a - - -{- ********************************************************************* -* * - Promotion flag -* * -********************************************************************* -} - --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data PromotionFlag - = NotPromoted - | IsPromoted - deriving ( Eq, Data ) - -isPromoted :: PromotionFlag -> Bool -isPromoted IsPromoted = True -isPromoted NotPromoted = False - -instance Outputable PromotionFlag where - ppr NotPromoted = text "NotPromoted" - ppr IsPromoted = text "IsPromoted" - -{- -************************************************************************ -* * -\subsection[FunctionOrData]{FunctionOrData} -* * -************************************************************************ --} - -data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord, Data) - -instance Outputable FunctionOrData where - ppr IsFunction = text "(function)" - ppr IsData = text "(data)" - -{- -************************************************************************ -* * -\subsection[Version]{Module and identifier version numbers} -* * -************************************************************************ --} - -type Version = Int - -bumpVersion :: Version -> Version -bumpVersion v = v+1 - -initialVersion :: Version -initialVersion = 1 - -{- -************************************************************************ -* * - Deprecations -* * -************************************************************************ --} - --- | A String Literal in the source, including its original raw format for use by --- source to source manipulation tools. -data StringLiteral = StringLiteral - { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] - sl_fs :: FastString -- literal string value - } deriving Data - -instance Eq StringLiteral where - (StringLiteral _ a) == (StringLiteral _ b) = a == b - -instance Outputable StringLiteral where - ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) - --- | Warning Text --- --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt (Located SourceText) - [Located StringLiteral] - | DeprecatedTxt (Located SourceText) - [Located StringLiteral] - deriving (Eq, Data) - -instance Outputable WarningTxt where - ppr (WarningTxt lsrc ws) - = case unLoc lsrc of - NoSourceText -> pp_ws ws - SourceText src -> text src <+> pp_ws ws <+> text "#-}" - - ppr (DeprecatedTxt lsrc ds) - = case unLoc lsrc of - NoSourceText -> pp_ws ds - SourceText src -> text src <+> pp_ws ds <+> text "#-}" - -pp_ws :: [Located StringLiteral] -> SDoc -pp_ws [l] = ppr $ unLoc l -pp_ws ws - = text "[" - <+> vcat (punctuate comma (map (ppr . unLoc) ws)) - <+> text "]" - - -pprWarningTxtForMsg :: WarningTxt -> SDoc -pprWarningTxtForMsg (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) -pprWarningTxtForMsg (DeprecatedTxt _ ds) - = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) - -{- -************************************************************************ -* * - Rules -* * -************************************************************************ --} - -type RuleName = FastString - -pprRuleName :: RuleName -> SDoc -pprRuleName rn = doubleQuotes (ftext rn) - -{- -************************************************************************ -* * -\subsection[Fixity]{Fixity info} -* * -************************************************************************ --} - ------------------------- -data Fixity = Fixity SourceText Int FixityDirection - -- Note [Pragma source text] - deriving Data - -instance Outputable Fixity where - ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 - ------------------------- -data FixityDirection = InfixL | InfixR | InfixN - deriving (Eq, Data) - -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - ------------------------- -maxPrecedence, minPrecedence :: Int -maxPrecedence = 9 -minPrecedence = 0 - -defaultFixity :: Fixity -defaultFixity = Fixity NoSourceText maxPrecedence InfixL - -negateFixity, funTyFixity :: Fixity --- Wired-in fixities -negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 - -{- -Consider - -\begin{verbatim} - a `op1` b `op2` c -\end{verbatim} -@(compareFixity op1 op2)@ tells which way to arrange application, or -whether there's an error. --} - -compareFixity :: Fixity -> Fixity - -> (Bool, -- Error please - Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) - = case prec1 `compare` prec2 of - GT -> left - LT -> right - EQ -> case (dir1, dir2) of - (InfixR, InfixR) -> right - (InfixL, InfixL) -> left - _ -> error_please - where - right = (False, True) - left = (False, False) - error_please = (True, False) - --- |Captures the fixity of declarations as they are parsed. This is not --- necessarily the same as the fixity declaration, as the normal fixity may be --- overridden using parens or backticks. -data LexicalFixity = Prefix | Infix deriving (Data,Eq) - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -{- -************************************************************************ -* * -\subsection[Top-level/local]{Top-level/not-top level flag} -* * -************************************************************************ --} - -data TopLevelFlag - = TopLevel - | NotTopLevel - -isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool - -isNotTopLevel NotTopLevel = True -isNotTopLevel TopLevel = False - -isTopLevel TopLevel = True -isTopLevel NotTopLevel = False - -instance Outputable TopLevelFlag where - ppr TopLevel = text "" - ppr NotTopLevel = text "" - -{- -************************************************************************ -* * - Boxity flag -* * -************************************************************************ --} - -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - -instance Outputable Boxity where - ppr Boxed = text "Boxed" - ppr Unboxed = text "Unboxed" - -{- -************************************************************************ -* * - Recursive/Non-Recursive flag -* * -************************************************************************ --} - --- | Recursivity Flag -data RecFlag = Recursive - | NonRecursive - deriving( Eq, Data ) - -isRec :: RecFlag -> Bool -isRec Recursive = True -isRec NonRecursive = False - -isNonRec :: RecFlag -> Bool -isNonRec Recursive = False -isNonRec NonRecursive = True - -boolToRecFlag :: Bool -> RecFlag -boolToRecFlag True = Recursive -boolToRecFlag False = NonRecursive - -instance Outputable RecFlag where - ppr Recursive = text "Recursive" - ppr NonRecursive = text "NonRecursive" - -{- -************************************************************************ -* * - Code origin -* * -************************************************************************ --} - -data Origin = FromSource - | Generated - deriving( Eq, Data ) - -isGenerated :: Origin -> Bool -isGenerated Generated = True -isGenerated FromSource = False - -instance Outputable Origin where - ppr FromSource = text "FromSource" - ppr Generated = text "Generated" - -{- -************************************************************************ -* * - Instance overlap flag -* * -************************************************************************ --} - --- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a --- explanation of the `isSafeOverlap` field. --- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or --- @'\{-\# OVERLAPPING'@ or --- @'\{-\# OVERLAPS'@ or --- @'\{-\# INCOHERENT'@, --- 'ApiAnnotation.AnnClose' @`\#-\}`@, - --- For details on above see note [Api annotations] in ApiAnnotation -data OverlapFlag = OverlapFlag - { overlapMode :: OverlapMode - , isSafeOverlap :: Bool - } deriving (Eq, Data) - -setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag -setOverlapModeMaybe f Nothing = f -setOverlapModeMaybe f (Just m) = f { overlapMode = m } - -hasIncoherentFlag :: OverlapMode -> Bool -hasIncoherentFlag mode = - case mode of - Incoherent _ -> True - _ -> False - -hasOverlappableFlag :: OverlapMode -> Bool -hasOverlappableFlag mode = - case mode of - Overlappable _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -hasOverlappingFlag :: OverlapMode -> Bool -hasOverlappingFlag mode = - case mode of - Overlapping _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -data OverlapMode -- See Note [Rules for instance lookup] in InstEnv - = NoOverlap SourceText - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - - | Overlapping SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - - | Overlaps SourceText - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent SourceText - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also note [Incoherent instances] in InstEnv - - deriving (Eq, Data) - - -instance Outputable OverlapFlag where - ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) - -instance Outputable OverlapMode where - ppr (NoOverlap _) = empty - ppr (Overlappable _) = text "[overlappable]" - ppr (Overlapping _) = text "[overlapping]" - ppr (Overlaps _) = text "[overlap ok]" - ppr (Incoherent _) = text "[incoherent]" - -pprSafeOverlap :: Bool -> SDoc -pprSafeOverlap True = text "[safe]" -pprSafeOverlap False = empty - -{- -************************************************************************ -* * - Precedence -* * -************************************************************************ --} - --- | A general-purpose pretty-printing precedence type. -newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) --- See Note [Precedence in types] - -topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec -topPrec = PprPrec 0 -- No parens -sigPrec = PprPrec 1 -- Explicit type signatures -funPrec = PprPrec 2 -- Function args; no parens for constructor apps - -- See [Type operator precedence] for why both - -- funPrec and opPrec exist. -opPrec = PprPrec 2 -- Infix operator -starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) - -- See Note [Star kind precedence] -appPrec = PprPrec 4 -- Constructor args; no parens for atomic - -maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - -{- Note [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Many pretty-printing functions have type - ppr_ty :: PprPrec -> Type -> SDoc - -The PprPrec gives the binding strength of the context. For example, in - T ty1 ty2 -we will pretty-print 'ty1' and 'ty2' with the call - (ppr_ty appPrec ty) -to indicate that the context is that of an argument of a TyConApp. - -We use this consistently for Type and HsType. - -Note [Type operator precedence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the -pretty printer follows the following precedence order: - - TyConPrec Type constructor application - TyOpPrec/FunPrec Operator application and function arrow - -We have funPrec and opPrec to represent the precedence of function -arrow and type operators respectively, but currently we implement -funPrec == opPrec, so that we don't distinguish the two. Reason: -it's hard to parse a type like - a ~ b => c * d -> e - f - -By treating opPrec = funPrec we end up with more parens - (a ~ b) => (c * d) -> (e - f) - -But the two are different constructors of PprPrec so we could make -(->) bind more or less tightly if we wanted. - -Note [Star kind precedence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We parenthesize the (*) kind to avoid two issues: - -1. Printing invalid or incorrect code. - For example, instead of type F @(*) x = x - GHC used to print type F @* x = x - However, (@*) is a type operator, not a kind application. - -2. Printing kinds that are correct but hard to read. - Should Either * Int be read as Either (*) Int - or as (*) Either Int ? - This depends on whether -XStarIsType is enabled, but it would be - easier if we didn't have to check for the flag when reading the code. - -At the same time, we cannot parenthesize (*) blindly. -Consider this Haskell98 kind: ((* -> *) -> *) -> * -With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*) - -The solution is to assign a special precedence to (*), 'starPrec', which is -higher than 'funPrec' but lower than 'appPrec': - - F * * * becomes F (*) (*) (*) - F A * B becomes F A (*) B - Proxy * becomes Proxy (*) - a * -> * becomes a (*) -> * --} - -{- -************************************************************************ -* * - Tuples -* * -************************************************************************ --} - -data TupleSort - = BoxedTuple - | UnboxedTuple - | ConstraintTuple - deriving( Eq, Data ) - -instance Outputable TupleSort where - ppr ts = text $ - case ts of - BoxedTuple -> "BoxedTuple" - UnboxedTuple -> "UnboxedTuple" - ConstraintTuple -> "ConstraintTuple" - -tupleSortBoxity :: TupleSort -> Boxity -tupleSortBoxity BoxedTuple = Boxed -tupleSortBoxity UnboxedTuple = Unboxed -tupleSortBoxity ConstraintTuple = Boxed - -boxityTupleSort :: Boxity -> TupleSort -boxityTupleSort Boxed = BoxedTuple -boxityTupleSort Unboxed = UnboxedTuple - -tupleParens :: TupleSort -> SDoc -> SDoc -tupleParens BoxedTuple p = parens p -tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") -tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) - (parens p) - -{- -************************************************************************ -* * - Sums -* * -************************************************************************ --} - -sumParens :: SDoc -> SDoc -sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") - --- | Pretty print an alternative in an unboxed sum e.g. "| a | |". -pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use - -> a -- ^ The things to be pretty printed - -> ConTag -- ^ Alternative (one-based) - -> Arity -- ^ Arity - -> SDoc -- ^ 'SDoc' where the alternative havs been pretty - -- printed and finally packed into a paragraph. -pprAlternative pp x alt arity = - fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) - -{- -************************************************************************ -* * -\subsection[Generic]{Generic flag} -* * -************************************************************************ - -This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedExpr's or Id's) -If we have a such a pair (EP from to), the idea is that 'from' and 'to' -represents functions of type - - from :: T -> Tring - to :: Tring -> T - -And we should have - - to (from x) = x - -T and Tring are arbitrary, but typically T is the 'main' type while -Tring is the 'representation' type. (This just helps us remember -whether to use 'from' or 'to'. --} - --- | Embedding Projection pair -data EP a = EP { fromEP :: a, -- :: T -> Tring - toEP :: a } -- :: Tring -> T - -{- -Embedding-projection pairs are used in several places: - -First of all, each type constructor has an EP associated with it, the -code in EP converts (datatype T) from T to Tring and back again. - -Secondly, when we are filling in Generic methods (in the typechecker, -tcMethodBinds), we are constructing bimaps by induction on the structure -of the type of the method signature. - - -************************************************************************ -* * -\subsection{Occurrence information} -* * -************************************************************************ - -This data type is used exclusively by the simplifier, but it appears in a -SubstResult, which is currently defined in VarEnv, which is pretty near -the base of the module hierarchy. So it seemed simpler to put the -defn of OccInfo here, safely at the bottom --} - --- | identifier Occurrence Information -data OccInfo - = ManyOccs { occ_tail :: !TailCallInfo } - -- ^ There are many occurrences, or unknown occurrences - - | IAmDead -- ^ Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. - - | OneOcc { occ_in_lam :: !InsideLam - , occ_one_br :: !OneBranch - , occ_int_cxt :: !InterestingCxt - , occ_tail :: !TailCallInfo } - -- ^ Occurs exactly once (per branch), not inside a rule - - -- | This identifier breaks a loop of mutually recursive functions. The field - -- marks whether it is only a loop breaker due to a reference in a rule - | IAmALoopBreaker { occ_rules_only :: !RulesOnly - , occ_tail :: !TailCallInfo } - -- Note [LoopBreaker OccInfo] - deriving (Eq) - -type RulesOnly = Bool - -{- -Note [LoopBreaker OccInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - IAmALoopBreaker True <=> A "weak" or rules-only loop breaker - Do not preInlineUnconditionally - - IAmALoopBreaker False <=> A "strong" loop breaker - Do not inline at all - -See OccurAnal Note [Weak loop breakers] --} - -noOccInfo :: OccInfo -noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } - -isManyOccs :: OccInfo -> Bool -isManyOccs ManyOccs{} = True -isManyOccs _ = False - -seqOccInfo :: OccInfo -> () -seqOccInfo occ = occ `seq` () - ------------------ --- | Interesting Context -data InterestingCxt - = IsInteresting - -- ^ Function: is applied - -- Data value: scrutinised by a case with at least one non-DEFAULT branch - | NotInteresting - deriving (Eq) - --- | If there is any 'interesting' identifier occurrence, then the --- aggregated occurrence info of that identifier is considered interesting. -instance Semi.Semigroup InterestingCxt where - NotInteresting <> x = x - IsInteresting <> _ = IsInteresting - -instance Monoid InterestingCxt where - mempty = NotInteresting - mappend = (Semi.<>) - ------------------ --- | Inside Lambda -data InsideLam - = IsInsideLam - -- ^ Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. - | NotInsideLam - deriving (Eq) - --- | If any occurrence of an identifier is inside a lambda, then the --- occurrence info of that identifier marks it as occurring inside a lambda -instance Semi.Semigroup InsideLam where - NotInsideLam <> x = x - IsInsideLam <> _ = IsInsideLam - -instance Monoid InsideLam where - mempty = NotInsideLam - mappend = (Semi.<>) - ------------------ -data OneBranch - = InOneBranch - -- ^ One syntactic occurrence: Occurs in only one case branch - -- so no code-duplication issue to worry about - | MultipleBranches - deriving (Eq) - ------------------ -data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] - | NoTailCallInfo - deriving (Eq) - -tailCallInfo :: OccInfo -> TailCallInfo -tailCallInfo IAmDead = NoTailCallInfo -tailCallInfo other = occ_tail other - -zapOccTailCallInfo :: OccInfo -> OccInfo -zapOccTailCallInfo IAmDead = IAmDead -zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } - -isAlwaysTailCalled :: OccInfo -> Bool -isAlwaysTailCalled occ - = case tailCallInfo occ of AlwaysTailCalled{} -> True - NoTailCallInfo -> False - -instance Outputable TailCallInfo where - ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] - ppr _ = empty - ------------------ -strongLoopBreaker, weakLoopBreaker :: OccInfo -strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo -weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo - -isWeakLoopBreaker :: OccInfo -> Bool -isWeakLoopBreaker (IAmALoopBreaker{}) = True -isWeakLoopBreaker _ = False - -isStrongLoopBreaker :: OccInfo -> Bool -isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True - -- Loop-breaker that breaks a non-rule cycle -isStrongLoopBreaker _ = False - -isDeadOcc :: OccInfo -> Bool -isDeadOcc IAmDead = True -isDeadOcc _ = False - -isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc {}) = True -isOneOcc _ = False - -zapFragileOcc :: OccInfo -> OccInfo --- Keep only the most robust data: deadness, loop-breaker-hood -zapFragileOcc (OneOcc {}) = noOccInfo -zapFragileOcc occ = zapOccTailCallInfo occ - -instance Outputable OccInfo where - -- only used for debugging; never parsed. KSW 1999-07 - ppr (ManyOccs tails) = pprShortTailCallInfo tails - ppr IAmDead = text "Dead" - ppr (IAmALoopBreaker rule_only tails) - = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails - where - pp_ro | rule_only = char '!' - | otherwise = empty - ppr (OneOcc inside_lam one_branch int_cxt tail_info) - = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail - where - pp_lam IsInsideLam = char 'L' - pp_lam NotInsideLam = empty - pp_br MultipleBranches = char '*' - pp_br InOneBranch = empty - pp_args IsInteresting = char '!' - pp_args NotInteresting = empty - pp_tail = pprShortTailCallInfo tail_info - -pprShortTailCallInfo :: TailCallInfo -> SDoc -pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) -pprShortTailCallInfo NoTailCallInfo = empty - -{- -Note [TailCallInfo] -~~~~~~~~~~~~~~~~~~~ -The occurrence analyser determines what can be made into a join point, but it -doesn't change the binder into a JoinId because then it would be inconsistent -with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to -change the IdDetails. - -The AlwaysTailCalled marker actually means slightly more than simply that the -function is always tail-called. See Note [Invariants on join points]. - -This info is quite fragile and should not be relied upon unless the occurrence -analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of -the join-point-hood of a binder; a join id itself will not be marked -AlwaysTailCalled. - -Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that -being tail-called would mean that the variable could only appear once per branch -(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join -point can also be invoked from other join points, not just from case branches: - - let j1 x = ... - j2 y = ... j1 z {- tail call -} ... - in case w of - A -> j1 v - B -> j2 u - C -> j2 q - -Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get -ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. - -************************************************************************ -* * - Default method specification -* * -************************************************************************ - -The DefMethSpec enumeration just indicates what sort of default method -is used for a class. It is generated from source code, and present in -interface files; it is converted to Class.DefMethInfo before begin put in a -Class object. --} - --- | Default Method Specification -data DefMethSpec ty - = VanillaDM -- Default method given with polymorphic code - | GenericDM ty -- Default method given with code of this type - -instance Outputable (DefMethSpec ty) where - ppr VanillaDM = text "{- Has default method -}" - ppr (GenericDM {}) = text "{- Has generic default method -}" - -{- -************************************************************************ -* * -\subsection{Success flag} -* * -************************************************************************ --} - -data SuccessFlag = Succeeded | Failed - -instance Outputable SuccessFlag where - ppr Succeeded = text "Succeeded" - ppr Failed = text "Failed" - -successIf :: Bool -> SuccessFlag -successIf True = Succeeded -successIf False = Failed - -succeeded, failed :: SuccessFlag -> Bool -succeeded Succeeded = True -succeeded Failed = False - -failed Succeeded = False -failed Failed = True - -{- -************************************************************************ -* * -\subsection{Source Text} -* * -************************************************************************ -Keeping Source Text for source to source conversions - -Note [Pragma source text] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer does a case-insensitive match for pragmas, as well as -accepting both UK and US spelling variants. - -So - - {-# SPECIALISE #-} - {-# SPECIALIZE #-} - {-# Specialize #-} - -will all generate ITspec_prag token for the start of the pragma. - -In order to be able to do source to source conversions, the original -source text for the token needs to be preserved, hence the -`SourceText` field. - -So the lexer will then generate - - ITspec_prag "{ -# SPECIALISE" - ITspec_prag "{ -# SPECIALIZE" - ITspec_prag "{ -# Specialize" - -for the cases above. - [without the space between '{' and '-', otherwise this comment won't parse] - - -Note [Literal source text] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer/parser converts literals from their original source text -versions to an appropriate internal representation. This is a problem -for tools doing source to source conversions, so the original source -text is stored in literals where this can occur. - -Motivating examples for HsLit - - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` - HsString "\x20\x41" == " A" - HsStringPrim "\x20"# == " "# - HsInt 001 == 1 - HsIntPrim 002# == 2# - HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## - HsInteger 006 == 6 - -For OverLitVal - - HsIntegral 003 == 0x003 - HsIsString "\x41nd" == "And" --} - - -- Note [Literal source text],[Pragma source text] -data SourceText = SourceText String - | NoSourceText -- ^ For when code is generated, e.g. TH, - -- deriving. The pretty printer will then make - -- its own representation of the item. - deriving (Data, Show, Eq ) - -instance Outputable SourceText where - ppr (SourceText s) = text "SourceText" <+> text s - ppr NoSourceText = text "NoSourceText" - --- | Special combinator for showing string literals. -pprWithSourceText :: SourceText -> SDoc -> SDoc -pprWithSourceText NoSourceText d = d -pprWithSourceText (SourceText src) _ = text src - -{- -************************************************************************ -* * -\subsection{Activation} -* * -************************************************************************ - -When a rule or inlining is active --} - --- | Phase Number -type PhaseNum = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase - -data CompilerPhase - = Phase PhaseNum - | InitialPhase -- The first phase -- number = infinity! - -instance Outputable CompilerPhase where - ppr (Phase n) = int n - ppr InitialPhase = text "InitialPhase" - -activeAfterInitial :: Activation --- Active in the first phase after the initial phase --- Currently we have just phases [2,1,0] -activeAfterInitial = ActiveAfter NoSourceText 2 - -activeDuringFinal :: Activation --- Active in the final simplification phase (which is repeated) -activeDuringFinal = ActiveAfter NoSourceText 0 - --- See note [Pragma source text] -data Activation = NeverActive - | AlwaysActive - | ActiveBefore SourceText PhaseNum - -- Active only *strictly before* this phase - | ActiveAfter SourceText PhaseNum - -- Active in this phase and later - deriving( Eq, Data ) - -- Eq used in comparing rules in GHC.Hs.Decls - --- | Rule Match Information -data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] - | FunLike - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -data InlinePragma -- Note [InlinePragma] - = InlinePragma - { inl_src :: SourceText -- Note [Pragma source text] - , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] - - , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n - -- explicit (non-type, non-dictionary) args - -- That is, inl_sat describes the number of *source-code* - -- arguments the thing must be applied to. We add on the - -- number of implicit, dictionary arguments when making - -- the Unfolding, and don't look at inl_sat further - - , inl_act :: Activation -- Says during which phases inlining is allowed - -- See Note [inl_inline and inl_act] - - , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? - } deriving( Eq, Data ) - --- | Inline Specification -data InlineSpec -- What the user's INLINE pragma looked like - = Inline -- User wrote INLINE - | Inlinable -- User wrote INLINABLE - | NoInline -- User wrote NOINLINE - | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE - -- e.g. in `defaultInlinePragma` or when created by CSE - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -{- Note [InlinePragma] -~~~~~~~~~~~~~~~~~~~~~~ -This data type mirrors what you can write in an INLINE or NOINLINE pragma in -the source program. - -If you write nothing at all, you get defaultInlinePragma: - inl_inline = NoUserInline - inl_act = AlwaysActive - inl_rule = FunLike - -It's not possible to get that combination by *writing* something, so -if an Id has defaultInlinePragma it means the user didn't specify anything. - -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. - -If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair - -Note [inl_inline and inl_act] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* inl_inline says what the user wrote: did she say INLINE, NOINLINE, - INLINABLE, or nothing at all - -* inl_act says in what phases the unfolding is active or inactive - E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 - If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 - If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 - So note that inl_act does not say what pragma you wrote: it just - expresses its consequences - -* inl_act just says when the unfolding is active; it doesn't say what - to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, - but in addition f will get a "stable unfolding" with UnfoldingGuidance - that tells the inliner to be pretty eager about it. - -Note [CONLIKE pragma] -~~~~~~~~~~~~~~~~~~~~~ -The ConLike constructor of a RuleMatchInfo is aimed at the following. -Consider first - {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} - g b bs = let x = b:bs in ..x...x...(r x)... -Now, the rule applies to the (r x) term, because GHC "looks through" -the definition of 'x' to see that it is (b:bs). - -Now consider - {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} - g v = let x = f v in ..x...x...(r x)... -Normally the (r x) would *not* match the rule, because GHC would be -scared about duplicating the redex (f v), so it does not "look -through" the bindings. - -However the CONLIKE modifier says to treat 'f' like a constructor in -this situation, and "look through" the unfolding for x. So (r x) -fires, yielding (f (v+1)). - -This is all controlled with a user-visible pragma: - {-# NOINLINE CONLIKE [1] f #-} - -The main effects of CONLIKE are: - - - The occurrence analyser (OccAnal) and simplifier (Simplify) treat - CONLIKE thing like constructors, by ANF-ing them - - - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but - additionally spots applications of CONLIKE functions - - - A CoreUnfolding has a field that caches exprIsExpandable - - - The rule matcher consults this field. See - Note [Expanding variables] in GHC.Core.Rules. --} - -isConLike :: RuleMatchInfo -> Bool -isConLike ConLike = True -isConLike _ = False - -isFunLike :: RuleMatchInfo -> Bool -isFunLike FunLike = True -isFunLike _ = False - -noUserInlineSpec :: InlineSpec -> Bool -noUserInlineSpec NoUserInline = True -noUserInlineSpec _ = False - -defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma - :: InlinePragma -defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_act = AlwaysActive - , inl_rule = FunLike - , inl_inline = NoUserInline - , inl_sat = Nothing } - -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } -neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } - -inlinePragmaSpec :: InlinePragma -> InlineSpec -inlinePragmaSpec = inl_inline - --- A DFun has an always-active inline activation so that --- exprIsConApp_maybe can "see" its unfolding --- (However, its actual Unfolding is a DFunUnfolding, which is --- never inlined other than via exprIsConApp_maybe.) -dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive - , inl_rule = ConLike } - -isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma { inl_act = activation - , inl_rule = match_info - , inl_inline = inline }) - = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info - -isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = case inl_inline prag of - Inline -> True - _ -> False - -isInlinablePragma :: InlinePragma -> Bool -isInlinablePragma prag = case inl_inline prag of - Inlinable -> True - _ -> False - -isAnyInlinePragma :: InlinePragma -> Bool --- INLINE or INLINABLE -isAnyInlinePragma prag = case inl_inline prag of - Inline -> True - Inlinable -> True - _ -> False - -inlinePragmaSat :: InlinePragma -> Maybe Arity -inlinePragmaSat = inl_sat - -inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation - -inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info - -setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation prag activation = prag { inl_act = activation } - -setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } - -instance Outputable Activation where - ppr AlwaysActive = empty - ppr NeverActive = brackets (text "~") - ppr (ActiveBefore _ n) = brackets (char '~' <> int n) - ppr (ActiveAfter _ n) = brackets (int n) - -instance Outputable RuleMatchInfo where - ppr ConLike = text "CONLIKE" - ppr FunLike = text "FUNLIKE" - -instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr NoUserInline = text "NOUSERINLINE" -- what is better? - -instance Outputable InlinePragma where - ppr = pprInline - -pprInline :: InlinePragma -> SDoc -pprInline = pprInline' True - -pprInlineDebug :: InlinePragma -> SDoc -pprInlineDebug = pprInline' False - -pprInline' :: Bool -- True <=> do not display the inl_inline field - -> InlinePragma - -> SDoc -pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation - , inl_rule = info, inl_sat = mb_arity }) - = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info - where - pp_inl x = if emptyInline then empty else ppr x - - pp_act Inline AlwaysActive = empty - pp_act NoInline NeverActive = empty - pp_act _ act = ppr act - - pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) - | otherwise = empty - pp_info | isFunLike info = empty - | otherwise = ppr info - -isActive :: CompilerPhase -> Activation -> Bool -isActive InitialPhase AlwaysActive = True -isActive InitialPhase (ActiveBefore {}) = True -isActive InitialPhase _ = False -isActive (Phase p) act = isActiveIn p act - -isActiveIn :: PhaseNum -> Activation -> Bool -isActiveIn _ NeverActive = False -isActiveIn _ AlwaysActive = True -isActiveIn p (ActiveAfter _ n) = p <= n -isActiveIn p (ActiveBefore _ n) = p > n - -competesWith :: Activation -> Activation -> Bool --- See Note [Activation competition] -competesWith NeverActive _ = False -competesWith _ NeverActive = False -competesWith AlwaysActive _ = True - -competesWith (ActiveBefore {}) AlwaysActive = True -competesWith (ActiveBefore {}) (ActiveBefore {}) = True -competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b - -competesWith (ActiveAfter {}) AlwaysActive = False -competesWith (ActiveAfter {}) (ActiveBefore {}) = False -competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b - -{- Note [Competing activations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes a RULE and an inlining may compete, or two RULES. -See Note [Rules and inlining/other rules] in GHC.HsToCore. - -We say that act1 "competes with" act2 iff - act1 is active in the phase when act2 *becomes* active -NB: remember that phases count *down*: 2, 1, 0! - -It's too conservative to ensure that the two are never simultaneously -active. For example, a rule might be always active, and an inlining -might switch on in phase 2. We could switch off the rule, but it does -no harm. --} - -isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool -isNeverActive NeverActive = True -isNeverActive _ = False - -isAlwaysActive AlwaysActive = True -isAlwaysActive _ = False - -isEarlyActive AlwaysActive = True -isEarlyActive (ActiveBefore {}) = True -isEarlyActive _ = False - --- | Integral Literal --- --- Used (instead of Integer) to represent negative zegative zero which is --- required for NegativeLiterals extension to correctly parse `-0::Double` --- as negative zero. See also #13211. -data IntegralLit - = IL { il_text :: SourceText - , il_neg :: Bool -- See Note [Negative zero] - , il_value :: Integer - } - deriving (Data, Show) - -mkIntegralLit :: Integral a => a -> IntegralLit -mkIntegralLit i = IL { il_text = SourceText (show i_integer) - , il_neg = i < 0 - , il_value = i_integer } - where - i_integer :: Integer - i_integer = toInteger i - -negateIntegralLit :: IntegralLit -> IntegralLit -negateIntegralLit (IL text neg value) - = case text of - SourceText ('-':src) -> IL (SourceText src) False (negate value) - SourceText src -> IL (SourceText ('-':src)) True (negate value) - NoSourceText -> IL NoSourceText (not neg) (negate value) - --- | Fractional Literal --- --- Used (instead of Rational) to represent exactly the floating point literal that we --- encountered in the user's source program. This allows us to pretty-print exactly what --- the user wrote, which is important e.g. for floating point numbers that can't represented --- as Doubles (we used to via Double for pretty-printing). See also #2245. -data FractionalLit - = FL { fl_text :: SourceText -- How the value was written in the source - , fl_neg :: Bool -- See Note [Negative zero] - , fl_value :: Rational -- Numeric value of the literal - } - deriving (Data, Show) - -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on - -mkFractionalLit :: Real a => a -> FractionalLit -mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) - -- Converting to a Double here may technically lose - -- precision (see #15502). We could alternatively - -- convert to a Rational for the most accuracy, but - -- it would cause Floats and Doubles to be displayed - -- strangely, so we opt not to do this. (In contrast - -- to mkIntegralLit, where we always convert to an - -- Integer for the highest accuracy.) - , fl_neg = r < 0 - , fl_value = toRational r } - -negateFractionalLit :: FractionalLit -> FractionalLit -negateFractionalLit (FL text neg value) - = case text of - SourceText ('-':src) -> FL (SourceText src) False value - SourceText src -> FL (SourceText ('-':src)) True value - NoSourceText -> FL NoSourceText (not neg) (negate value) - -integralFractionalLit :: Bool -> Integer -> FractionalLit -integralFractionalLit neg i = FL { fl_text = SourceText (show i), - fl_neg = neg, - fl_value = fromInteger i } - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) - -instance Eq IntegralLit where - (==) = (==) `on` il_value - -instance Ord IntegralLit where - compare = compare `on` il_value - -instance Outputable IntegralLit where - ppr (IL (SourceText src) _ _) = text src - ppr (IL NoSourceText _ value) = text (show value) - -instance Eq FractionalLit where - (==) = (==) `on` fl_value - -instance Ord FractionalLit where - compare = compare `on` fl_value - -instance Outputable FractionalLit where - ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) - -{- -************************************************************************ -* * - IntWithInf -* * -************************************************************************ - -Represents an integer or positive infinity - --} - --- | An integer or infinity -data IntWithInf = Int {-# UNPACK #-} !Int - | Infinity - deriving Eq - --- | A representation of infinity -infinity :: IntWithInf -infinity = Infinity - -instance Ord IntWithInf where - compare Infinity Infinity = EQ - compare (Int _) Infinity = LT - compare Infinity (Int _) = GT - compare (Int a) (Int b) = a `compare` b - -instance Outputable IntWithInf where - ppr Infinity = char '∞' - ppr (Int n) = int n - -instance Num IntWithInf where - (+) = plusWithInf - (*) = mulWithInf - - abs Infinity = Infinity - abs (Int n) = Int (abs n) - - signum Infinity = Int 1 - signum (Int n) = Int (signum n) - - fromInteger = Int . fromInteger - - (-) = panic "subtracting IntWithInfs" - -intGtLimit :: Int -> IntWithInf -> Bool -intGtLimit _ Infinity = False -intGtLimit n (Int m) = n > m - --- | Add two 'IntWithInf's -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf -plusWithInf Infinity _ = Infinity -plusWithInf _ Infinity = Infinity -plusWithInf (Int a) (Int b) = Int (a + b) - --- | Multiply two 'IntWithInf's -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf -mulWithInf Infinity _ = Infinity -mulWithInf _ Infinity = Infinity -mulWithInf (Int a) (Int b) = Int (a * b) - --- | Turn a positive number into an 'IntWithInf', where 0 represents infinity -treatZeroAsInf :: Int -> IntWithInf -treatZeroAsInf 0 = Infinity -treatZeroAsInf n = Int n - --- | Inject any integer into an 'IntWithInf' -mkIntWithInf :: Int -> IntWithInf -mkIntWithInf = Int - -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 diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs deleted file mode 100644 --- a/compiler/basicTypes/ConLike.hs +++ /dev/null @@ -1,196 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[ConLike]{@ConLike@: Constructor-like things} --} - -{-# LANGUAGE CPP #-} - -module ConLike ( - ConLike(..) - , conLikeArity - , conLikeFieldLabels - , conLikeInstOrigArgTys - , conLikeExTyCoVars - , conLikeName - , conLikeStupidTheta - , conLikeWrapId_maybe - , conLikeImplBangs - , conLikeFullSig - , conLikeResTy - , conLikeFieldType - , conLikesWithFields - , conLikeIsInfix - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DataCon -import PatSyn -import Outputable -import Unique -import Util -import Name -import BasicTypes -import TyCoRep (Type, ThetaType) -import Var -import Type (mkTyConApp) - -import qualified Data.Data as Data - -{- -************************************************************************ -* * -\subsection{Constructor-like things} -* * -************************************************************************ --} - --- | A constructor-like thing -data ConLike = RealDataCon DataCon - | PatSynCon PatSyn - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq ConLike where - (==) = eqConLike - -eqConLike :: ConLike -> ConLike -> Bool -eqConLike x y = getUnique x == getUnique y - --- There used to be an Ord ConLike instance here that used Unique for ordering. --- It was intentionally removed to prevent determinism problems. --- See Note [Unique Determinism] in Unique. - -instance Uniquable ConLike where - getUnique (RealDataCon dc) = getUnique dc - getUnique (PatSynCon ps) = getUnique ps - -instance NamedThing ConLike where - getName (RealDataCon dc) = getName dc - getName (PatSynCon ps) = getName ps - -instance Outputable ConLike where - ppr (RealDataCon dc) = ppr dc - ppr (PatSynCon ps) = ppr ps - -instance OutputableBndr ConLike where - pprInfixOcc (RealDataCon dc) = pprInfixOcc dc - pprInfixOcc (PatSynCon ps) = pprInfixOcc ps - pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc - pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps - -instance Data.Data ConLike where - -- don't traverse? - toConstr _ = abstractConstr "ConLike" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ConLike" - --- | Number of arguments -conLikeArity :: ConLike -> Arity -conLikeArity (RealDataCon data_con) = dataConSourceArity data_con -conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn - --- | Names of fields used for selectors -conLikeFieldLabels :: ConLike -> [FieldLabel] -conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con -conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn - --- | Returns just the instantiated /value/ argument types of a 'ConLike', --- (excluding dictionary args) -conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] -conLikeInstOrigArgTys (RealDataCon data_con) tys = - dataConInstOrigArgTys data_con tys -conLikeInstOrigArgTys (PatSynCon pat_syn) tys = - patSynInstArgTys pat_syn tys - --- | Existentially quantified type/coercion variables -conLikeExTyCoVars :: ConLike -> [TyCoVar] -conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 -conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 - -conLikeName :: ConLike -> Name -conLikeName (RealDataCon data_con) = dataConName data_con -conLikeName (PatSynCon pat_syn) = patSynName pat_syn - --- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: --- --- > data Eq a => T a = ... --- It is empty for `PatSynCon` as they do not allow such contexts. -conLikeStupidTheta :: ConLike -> ThetaType -conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con -conLikeStupidTheta (PatSynCon {}) = [] - --- | Returns the `Id` of the wrapper. This is also known as the builder in --- some contexts. The value is Nothing only in the case of unidirectional --- pattern synonyms. -conLikeWrapId_maybe :: ConLike -> Maybe Id -conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con -conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn - --- | Returns the strictness information for each constructor -conLikeImplBangs :: ConLike -> [HsImplBang] -conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con -conLikeImplBangs (PatSynCon pat_syn) = - replicate (patSynArity pat_syn) HsLazy - --- | Returns the type of the whole pattern -conLikeResTy :: ConLike -> [Type] -> Type -conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys -conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys - --- | The \"full signature\" of the 'ConLike' returns, in order: --- --- 1) The universally quantified type variables --- --- 2) The existentially quantified type/coercion variables --- --- 3) The equality specification --- --- 4) The provided theta (the constraints provided by a match) --- --- 5) The required theta (the constraints required for a match) --- --- 6) The original argument types (i.e. before --- any change of the representation of the type) --- --- 7) The original result type -conLikeFullSig :: ConLike - -> ([TyVar], [TyCoVar], [EqSpec] - -- Why tyvars for universal but tycovars for existential? - -- See Note [Existential coercion variables] in DataCon - , ThetaType, ThetaType, [Type], Type) -conLikeFullSig (RealDataCon con) = - let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con - -- Required theta is empty as normal data cons require no additional - -- constraints for a match - in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) -conLikeFullSig (PatSynCon pat_syn) = - let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn - -- eqSpec is empty - in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) - --- | Extract the type for any given labelled field of the 'ConLike' -conLikeFieldType :: ConLike -> FieldLabelString -> Type -conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label -conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label - - --- | The ConLikes that have *all* the given fields -conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] -conLikesWithFields con_likes lbls = filter has_flds con_likes - where has_flds dc = all (has_fld dc) lbls - has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) - -conLikeIsInfix :: ConLike -> Bool -conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc -conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/compiler/basicTypes/ConLike.hs-boot b/compiler/basicTypes/ConLike.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/ConLike.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module ConLike where -import {-# SOURCE #-} DataCon (DataCon) -import {-# SOURCE #-} PatSyn (PatSyn) -import Name ( Name ) - -data ConLike = RealDataCon DataCon - | PatSynCon PatSyn - -conLikeName :: ConLike -> Name diff --git a/compiler/basicTypes/Cpr.hs b/compiler/basicTypes/Cpr.hs deleted file mode 100644 --- a/compiler/basicTypes/Cpr.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE GeneralisedNewtypeDeriving #-} --- | Types for the Constructed Product Result lattice. "CprAnal" and "WwLib" --- are its primary customers via 'idCprInfo'. -module Cpr ( - CprResult, topCpr, botCpr, conCpr, asConCpr, - CprType (..), topCprType, botCprType, conCprType, - lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy, - CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig - ) where - -import GhcPrelude - -import BasicTypes -import Outputable -import Binary - --- --- * CprResult --- - --- | The constructed product result lattice. --- --- @ --- NoCPR --- | --- ConCPR ConTag --- | --- BotCPR --- @ -data CprResult = NoCPR -- ^ Top of the lattice - | ConCPR !ConTag -- ^ Returns a constructor from a data type - | BotCPR -- ^ Bottom of the lattice - deriving( Eq, Show ) - -lubCpr :: CprResult -> CprResult -> CprResult -lubCpr (ConCPR t1) (ConCPR t2) - | t1 == t2 = ConCPR t1 -lubCpr BotCPR cpr = cpr -lubCpr cpr BotCPR = cpr -lubCpr _ _ = NoCPR - -topCpr :: CprResult -topCpr = NoCPR - -botCpr :: CprResult -botCpr = BotCPR - -conCpr :: ConTag -> CprResult -conCpr = ConCPR - -trimCpr :: CprResult -> CprResult -trimCpr ConCPR{} = NoCPR -trimCpr cpr = cpr - -asConCpr :: CprResult -> Maybe ConTag -asConCpr (ConCPR t) = Just t -asConCpr NoCPR = Nothing -asConCpr BotCPR = Nothing - --- --- * CprType --- - --- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. -data CprType - = CprType - { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression - -- eats before returning the 'ct_cpr' - , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to - -- 'ct_arty' arguments - } - -instance Eq CprType where - a == b = ct_cpr a == ct_cpr b - && (ct_arty a == ct_arty b || ct_cpr a == topCpr) - -topCprType :: CprType -topCprType = CprType 0 topCpr - -botCprType :: CprType -botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments - -conCprType :: ConTag -> CprType -conCprType con_tag = CprType 0 (conCpr con_tag) - -lubCprType :: CprType -> CprType -> CprType -lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) - -- The arity of bottom CPR types can be extended arbitrarily. - | cpr1 == botCpr && n1 <= n2 = ty2 - | cpr2 == botCpr && n2 <= n1 = ty1 - -- There might be non-bottom CPR types with mismatching arities. - -- Consider test DmdAnalGADTs. We want to return top in these cases. - | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) - | otherwise = topCprType - -applyCprTy :: CprType -> CprType -applyCprTy (CprType n res) - | n > 0 = CprType (n-1) res - | res == botCpr = botCprType - | otherwise = topCprType - -abstractCprTy :: CprType -> CprType -abstractCprTy (CprType n res) - | res == topCpr = topCprType - | otherwise = CprType (n+1) res - -ensureCprTyArity :: Arity -> CprType -> CprType -ensureCprTyArity n ty@(CprType m _) - | n == m = ty - | otherwise = topCprType - -trimCprTy :: CprType -> CprType -trimCprTy (CprType arty res) = CprType arty (trimCpr res) - --- | The arity of the wrapped 'CprType' is the arity at which it is safe --- to unleash. See Note [Understanding DmdType and StrictSig] in Demand -newtype CprSig = CprSig { getCprSig :: CprType } - deriving (Eq, Binary) - --- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in --- Demand -mkCprSigForArity :: Arity -> CprType -> CprSig -mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) - -topCprSig :: CprSig -topCprSig = CprSig topCprType - -mkCprSig :: Arity -> CprResult -> CprSig -mkCprSig arty cpr = CprSig (CprType arty cpr) - -seqCprSig :: CprSig -> () -seqCprSig sig = sig `seq` () - -instance Outputable CprResult where - ppr NoCPR = empty - ppr (ConCPR n) = char 'm' <> int n - ppr BotCPR = char 'b' - -instance Outputable CprType where - ppr (CprType arty res) = ppr arty <> ppr res - --- | Only print the CPR result -instance Outputable CprSig where - ppr (CprSig ty) = ppr (ct_cpr ty) - -instance Binary CprResult where - put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } - put_ bh NoCPR = putByte bh 1 - put_ bh BotCPR = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; return (ConCPR n) } - 1 -> return NoCPR - _ -> return BotCPR - -instance Binary CprType where - put_ bh (CprType arty cpr) = do - put_ bh arty - put_ bh cpr - get bh = CprType <$> get bh <*> get bh diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs deleted file mode 100644 --- a/compiler/basicTypes/DataCon.hs +++ /dev/null @@ -1,1468 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[DataCon]{@DataCon@: Data Constructors} --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module DataCon ( - -- * Main data types - DataCon, DataConRep(..), - SrcStrictness(..), SrcUnpackedness(..), - HsSrcBang(..), HsImplBang(..), - StrictnessMark(..), - ConTag, - - -- ** Equality specs - EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, - eqSpecPair, eqSpecPreds, - substEqSpec, filterEqSpec, - - -- ** Field labels - FieldLbl(..), FieldLabel, FieldLabelString, - - -- ** Type construction - mkDataCon, fIRST_TAG, - - -- ** Type deconstruction - dataConRepType, dataConInstSig, dataConFullSig, - dataConName, dataConIdentity, dataConTag, dataConTagZ, - dataConTyCon, dataConOrigTyCon, - dataConUserType, - dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, - dataConUserTyVars, dataConUserTyVarBinders, - dataConEqSpec, dataConTheta, - dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, - dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, - dataConSrcBangs, - dataConSourceArity, dataConRepArity, - dataConIsInfix, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, - dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, - - splitDataProductType_maybe, - - -- ** Predicates on DataCons - isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, - isUnboxedSumCon, - isVanillaDataCon, classDataCon, dataConCannotMatch, - dataConUserTyVarsArePermuted, - isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, - specialPromotedDc, - - -- ** Promotion related functions - promoteDataCon - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} MkId( DataConBoxer ) -import Type -import Coercion -import Unify -import TyCon -import FieldLabel -import Class -import Name -import PrelNames -import Predicate -import Var -import Outputable -import Util -import BasicTypes -import FastString -import Module -import Binary -import UniqSet -import Unique( mkAlphaTyVarUnique ) - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Builder as BSB -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Data as Data -import Data.Char -import Data.List( find ) - -{- -Data constructor representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following Haskell data type declaration - - data T = T !Int ![Int] - -Using the strictness annotations, GHC will represent this as - - data T = T Int# [Int] - -That is, the Int has been unboxed. Furthermore, the Haskell source construction - - T e1 e2 - -is translated to - - case e1 of { I# x -> - case e2 of { r -> - T x r }} - -That is, the first argument is unboxed, and the second is evaluated. Finally, -pattern matching is translated too: - - case e of { T a b -> ... } - -becomes - - case e of { T a' b -> let a = I# a' in ... } - -To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. - - -Note [Data Constructor Naming] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly up to four, Names associated with it: - - OccName Name space Name of Notes - --------------------------------------------------------------------------- - The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) - The "worker data con" C VarName Id The worker - The "wrapper data con" $WC VarName Id The wrapper - The "newtype coercion" :CoT TcClsName TyCon - -EVERY data constructor (incl for newtypes) has the former two (the -data con itself, and its worker. But only some data constructors have a -wrapper (see Note [The need for a wrapper]). - -Each of these three has a distinct Unique. The "data con itself" name -appears in the output of the renamer, and names the Haskell-source -data constructor. The type checker translates it into either the wrapper Id -(if it exists) or worker Id (otherwise). - -The data con has one or two Ids associated with it: - -The "worker Id", is the actual data constructor. -* Every data constructor (newtype or data type) has a worker - -* The worker is very like a primop, in that it has no binding. - -* For a *data* type, the worker *is* the data constructor; - it has no unfolding - -* For a *newtype*, the worker has a compulsory unfolding which - does a cast, e.g. - newtype T = MkT Int - The worker for MkT has unfolding - \\(x:Int). x `cast` sym CoT - Here CoT is the type constructor, witnessing the FC axiom - axiom CoT : T = Int - -The "wrapper Id", \$WC, goes as follows - -* Its type is exactly what it looks like in the source program. - -* It is an ordinary function, and it gets a top-level binding - like any other function. - -* The wrapper Id isn't generated for a data type if there is - nothing for the wrapper to do. That is, if its defn would be - \$wC = C - -Note [Data constructor workers and wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Algebraic data types - - Always have a worker, with no unfolding - - May or may not have a wrapper; see Note [The need for a wrapper] - -* Newtypes - - Always have a worker, which has a compulsory unfolding (just a cast) - - May or may not have a wrapper; see Note [The need for a wrapper] - -* INVARIANT: the dictionary constructor for a class - never has a wrapper. - -* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments - -* The wrapper (if it exists) takes dcOrigArgTys as its arguments - The worker takes dataConRepArgTys as its arguments - If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys - -* The 'NoDataConRep' case of DataConRep is important. Not only is it - efficient, but it also ensures that the wrapper is replaced by the - worker (because it *is* the worker) even when there are no - args. E.g. in - f (:) x - the (:) *is* the worker. This is really important in rule matching, - (We could match on the wrappers, but that makes it less likely that - rules will match when we bring bits of unfoldings together.) - -Note [The need for a wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why might the wrapper have anything to do? The full story is -in wrapper_reqd in MkId.mkDataConRep. - -* Unboxing strict fields (with -funbox-strict-fields) - data T = MkT !(Int,Int) - \$wMkT :: (Int,Int) -> T - \$wMkT (x,y) = MkT x y - Notice that the worker has two fields where the wapper has - just one. That is, the worker has type - MkT :: Int -> Int -> T - -* Equality constraints for GADTs - data T a where { MkT :: a -> T [a] } - - The worker gets a type with explicit equality - constraints, thus: - MkT :: forall a b. (a=[b]) => b -> T a - - The wrapper has the programmer-specified type: - \$wMkT :: a -> T [a] - \$wMkT a x = MkT [a] a [a] x - The third argument is a coercion - [a] :: [a]~[a] - -* Data family instances may do a cast on the result - -* Type variables may be permuted; see MkId - Note [Data con wrappers and GADT syntax] - - -Note [The stupid context] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Data types can have a context: - - data (Eq a, Ord b) => T a b = T1 a b | T2 a - -and that makes the constructors have a context too -(notice that T2's context is "thinned"): - - T1 :: (Eq a, Ord b) => a -> b -> T a b - T2 :: (Eq a) => a -> T a b - -Furthermore, this context pops up when pattern matching -(though GHC hasn't implemented this, but it is in H98, and -I've fixed GHC so that it now does): - - f (T2 x) = x -gets inferred type - f :: Eq a => T a b -> a - -I say the context is "stupid" because the dictionaries passed -are immediately discarded -- they do nothing and have no benefit. -It's a flaw in the language. - - Up to now [March 2002] I have put this stupid context into the - type of the "wrapper" constructors functions, T1 and T2, but - that turned out to be jolly inconvenient for generics, and - record update, and other functions that build values of type T - (because they don't have suitable dictionaries available). - - So now I've taken the stupid context out. I simply deal with - it separately in the type checker on occurrences of a - constructor, either in an expression or in a pattern. - - [May 2003: actually I think this decision could easily be - reversed now, and probably should be. Generics could be - disabled for types with a stupid context; record updates now - (H98) needs the context too; etc. It's an unforced change, so - I'm leaving it for now --- but it does seem odd that the - wrapper doesn't include the stupid context.] - -[July 04] With the advent of generalised data types, it's less obvious -what the "stupid context" is. Consider - C :: forall a. Ord a => a -> a -> T (Foo a) -Does the C constructor in Core contain the Ord dictionary? Yes, it must: - - f :: T b -> Ordering - f = /\b. \x:T b. - case x of - C a (d:Ord a) (p:a) (q:a) -> compare d p q - -Note that (Foo a) might not be an instance of Ord. - -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ --} - --- | A data constructor --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' - --- For details on above see note [Api annotations] in ApiAnnotation -data DataCon - = MkData { - dcName :: Name, -- This is the name of the *source data con* - -- (see "Note [Data Constructor Naming]" above) - dcUnique :: Unique, -- Cached from Name - dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's - - -- Running example: - -- - -- *** As declared by the user - -- data T a b c where - -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c - - -- *** As represented internally - -- data T a b c where - -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) - -- => x -> y -> T a b c - -- - -- The next six fields express the type of the constructor, in pieces - -- e.g. - -- - -- dcUnivTyVars = [a,b,c] - -- dcExTyCoVars = [x,y] - -- dcUserTyVarBinders = [c,y,x,b] - -- dcEqSpec = [a~(x,y)] - -- dcOtherTheta = [x~y, Ord x] - -- dcOrigArgTys = [x,y] - -- dcRepTyCon = T - - -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE - -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, - -- vanilla datacons guaranteed to have the same type variables as their - -- parent TyCon, but that seems ugly.) They can be different in the case - -- where a GADT constructor uses different names for the universal - -- tyvars than does the tycon. For example: - -- - -- data H a where - -- MkH :: b -> H b - -- - -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH - -- will be [b]. - - dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor - -- Its type is of form - -- forall a1..an . t1 -> ... tm -> T a1..an - -- No existentials, no coercions, nothing. - -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] - -- NB 1: newtypes always have a vanilla data con - -- NB 2: a vanilla constructor can still be declared in GADT-style - -- syntax, provided its type looks like the above. - -- The declaration format is held in the TyCon (algTcGadtSyntax) - - -- Universally-quantified type vars [a,b,c] - -- INVARIANT: length matches arity of the dcRepTyCon - -- INVARIANT: result type of data con worker is exactly (T a b c) - -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with - -- the tyConTyVars of the parent TyCon - dcUnivTyVars :: [TyVar], - - -- Existentially-quantified type and coercion vars [x,y] - -- For an example involving coercion variables, - -- Why tycovars? See Note [Existential coercion variables] - dcExTyCoVars :: [TyCoVar], - - -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames - -- Reason: less confusing, and easier to generate Iface syntax - - -- The type/coercion vars in the order the user wrote them [c,y,x,b] - -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set - -- of tyvars (*not* covars) of dcExTyCoVars unioned with the - -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec - -- See Note [DataCon user type variable binders] - dcUserTyVarBinders :: [TyVarBinder], - - dcEqSpec :: [EqSpec], -- Equalities derived from the result type, - -- _as written by the programmer_. - -- Only non-dependent GADT equalities (dependent - -- GADT equalities are in the covars of - -- dcExTyCoVars). - - -- This field allows us to move conveniently between the two ways - -- of representing a GADT constructor's type: - -- MkT :: forall a b. (a ~ [b]) => b -> T a - -- MkT :: forall b. b -> T [b] - -- Each equality is of the form (a ~ ty), where 'a' is one of - -- the universally quantified type variables - - -- The next two fields give the type context of the data constructor - -- (aside from the GADT constraints, - -- which are given by the dcExpSpec) - -- In GADT form, this is *exactly* what the programmer writes, even if - -- the context constrains only universally quantified variables - -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b - dcOtherTheta :: ThetaType, -- The other constraints in the data con's type - -- other than those in the dcEqSpec - - dcStupidTheta :: ThetaType, -- The context of the data type declaration - -- data Eq a => T a = ... - -- or, rather, a "thinned" version thereof - -- "Thinned", because the Report says - -- to eliminate any constraints that don't mention - -- tyvars free in the arg types for this constructor - -- - -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars - -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon - -- - -- "Stupid", because the dictionaries aren't used for anything. - -- Indeed, [as of March 02] they are no longer in the type of - -- the wrapper Id, because that makes it harder to use the wrap-id - -- to rebuild values after record selection or in generics. - - dcOrigArgTys :: [Type], -- Original argument types - -- (before unboxing and flattening of strict fields) - dcOrigResTy :: Type, -- Original result type, as seen by the user - -- NB: for a data instance, the original user result type may - -- differ from the DataCon's representation TyCon. Example - -- data instance T [a] where MkT :: a -> T [a] - -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 - - -- Now the strictness annotations and field labels of the constructor - dcSrcBangs :: [HsSrcBang], - -- See Note [Bangs on data constructor arguments] - -- - -- The [HsSrcBang] as written by the programmer. - -- - -- Matches 1-1 with dcOrigArgTys - -- Hence length = dataConSourceArity dataCon - - dcFields :: [FieldLabel], - -- Field labels for this constructor, in the - -- same order as the dcOrigArgTys; - -- length = 0 (if not a record) or dataConSourceArity. - - -- The curried worker function that corresponds to the constructor: - -- It doesn't have an unfolding; the code generator saturates these Ids - -- and allocates a real constructor when it finds one. - dcWorkId :: Id, - - -- Constructor representation - dcRep :: DataConRep, - - -- Cached; see Note [DataCon arities] - -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) - -- INVARIANT: dcSourceArity == length dcOrigArgTys - dcRepArity :: Arity, - dcSourceArity :: Arity, - - -- Result type of constructor is T t1..tn - dcRepTyCon :: TyCon, -- Result tycon, T - - dcRepType :: Type, -- Type of the constructor - -- forall a x y. (a~(x,y), x~y, Ord x) => - -- x -> y -> T a - -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) - -- Notice that the existential type parameters come *second*. - -- Reason: in a case expression we may find: - -- case (e :: T t) of - -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... - -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t - -- and use that to check the pattern. Mind you, this is really only - -- used in GHC.Core.Lint. - - - dcInfix :: Bool, -- True <=> declared infix - -- Used for Template Haskell and 'deriving' only - -- The actual fixity is stored elsewhere - - dcPromoted :: TyCon -- The promoted TyCon - -- See Note [Promoted data constructors] in TyCon - } - - -{- Note [TyVarBinders in DataCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the TyVarBinders in a DataCon and PatSyn: - - * Each argument flag is Inferred or Specified. - None are Required. (A DataCon is a term-level function; see - Note [No Required TyCoBinder in terms] in TyCoRep.) - -Why do we need the TyVarBinders, rather than just the TyVars? So that -we can construct the right type for the DataCon with its foralls -attributed the correct visibility. That in turn governs whether you -can use visible type application at a call of the data constructor. - -See also [DataCon user type variable binders] for an extended discussion on the -order in which TyVarBinders appear in a DataCon. - -Note [Existential coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For now (Aug 2018) we can't write coercion quantifications in source Haskell, but -we can in Core. Consider having: - - data T :: forall k. k -> k -> Constraint where - MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) - => T k a b - - dcUnivTyVars = [k,a,b] - dcExTyCoVars = [k',c,co] - dcUserTyVarBinders = [k,a,k',c] - dcEqSpec = [b~(c|>co)] - dcOtherTheta = [] - dcOrigArgTys = [] - dcRepTyCon = T - - Function call 'dataConKindEqSpec' returns [k'~k] - -Note [DataCon arities] -~~~~~~~~~~~~~~~~~~~~~~ -dcSourceArity does not take constraints into account, -but dcRepArity does. For example: - MkT :: Ord a => a -> T a - dcSourceArity = 1 - dcRepArity = 2 - -Note [DataCon user type variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In System FC, data constructor type signatures always quantify over all of -their universal type variables, followed by their existential type variables. -Normally, this isn't a problem, as most datatypes naturally quantify their type -variables in this order anyway. For example: - - data T a b = forall c. MkT b c - -Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, -where k, a, and b are universal and c is existential. (The inferred variable k -isn't available for TypeApplications, hence why it's in braces.) This is a -perfectly reasonable order to use, as the syntax of H98-style datatypes -(+ ExistentialQuantification) suggests it. - -Things become more complicated when GADT syntax enters the picture. Consider -this example: - - data X a where - MkX :: forall b a. b -> Proxy a -> X a - -If we adopt the earlier approach of quantifying all the universal variables -followed by all the existential ones, GHC would come up with this type -signature for MkX: - - MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a - -But this is not what we want at all! After all, if a user were to use -TypeApplications on MkX, they would expect to instantiate `b` before `a`, -as that's the order in which they were written in the `forall`. (See #11721.) -Instead, we'd like GHC to come up with this type signature: - - MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a - -In fact, even if we left off the explicit forall: - - data X a where - MkX :: b -> Proxy a -> X a - -Then a user should still expect `b` to be quantified before `a`, since -according to the rules of TypeApplications, in the absence of `forall` GHC -performs a stable topological sort on the type variables in the user-written -type signature, which would place `b` before `a`. - -But as noted above, enacting this behavior is not entirely trivial, as System -FC demands the variables go in universal-then-existential order under the hood. -Our solution is thus to equip DataCon with two different sets of type -variables: - -* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential - type/coercion variables, respectively. Their order is irrelevant for the - purposes of TypeApplications, and as a consequence, they do not come equipped - with visibilities (that is, they are TyVars/TyCoVars instead of - TyCoVarBinders). -* dcUserTyVarBinders, for the type variables binders in the order in which they - originally arose in the user-written type signature. Their order *does* matter - for TypeApplications, so they are full TyVarBinders, complete with - visibilities. - -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders -consists precisely of: - -* The set of tyvars in dcUnivTyVars whose type variables do not appear in - dcEqSpec, unioned with: -* The set of tyvars (*not* covars) in dcExTyCoVars - No covars here because because they're not user-written - -The word "set" is used above because the order in which the tyvars appear in -dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or -dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of -(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the -ordering, they in fact share the same type variables (with the same Uniques). We -sometimes refer to this as "the dcUserTyVarBinders invariant". - -dcUserTyVarBinders, as the name suggests, is the one that users will see most of -the time. It's used when computing the type signature of a data constructor (see -dataConUserType), and as a result, it's what matters from a TypeApplications -perspective. --} - --- | Data Constructor Representation --- See Note [Data constructor workers and wrappers] -data DataConRep - = -- NoDataConRep means that the data con has no wrapper - NoDataConRep - - -- DCR means that the data con has a wrapper - | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, - -- and constructs the representation - - , dcr_boxer :: DataConBoxer - - , dcr_arg_tys :: [Type] -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* all evidence args - - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] in MkId.hs - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - - } - -------------------------- - --- | Haskell Source Bang --- --- Bangs on data constructor arguments as the user wrote them in the --- source code. --- --- @(HsSrcBang _ SrcUnpack SrcLazy)@ and --- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we --- emit a warning (in checkValidDataCon) and treat it like --- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ -data HsSrcBang = - HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes - SrcUnpackedness - SrcStrictness - deriving Data.Data - --- | Haskell Implementation Bang --- --- Bangs of data constructor arguments as generated by the compiler --- after consulting HsSrcBang, flags, etc. -data HsImplBang - = HsLazy -- ^ Lazy field, or one with an unlifted type - | HsStrict -- ^ Strict but not unpacked field - | HsUnpack (Maybe Coercion) - -- ^ Strict and unpacked field - -- co :: arg-ty ~ product-ty HsBang - deriving Data.Data - --- | Source Strictness --- --- What strictness annotation the user wrote -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - deriving (Eq, Data.Data) - --- | Source Unpackedness --- --- What unpackedness the user requested -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - deriving (Eq, Data.Data) - - - -------------------------- --- StrictnessMark is internal only, used to indicate strictness --- of the DataCon *worker* fields -data StrictnessMark = MarkedStrict | NotMarkedStrict - --- | An 'EqSpec' is a tyvar/type pair representing an equality made in --- rejigging a GADT constructor -data EqSpec = EqSpec TyVar - Type - --- | Make a non-dependent 'EqSpec' -mkEqSpec :: TyVar -> Type -> EqSpec -mkEqSpec tv ty = EqSpec tv ty - -eqSpecTyVar :: EqSpec -> TyVar -eqSpecTyVar (EqSpec tv _) = tv - -eqSpecType :: EqSpec -> Type -eqSpecType (EqSpec _ ty) = ty - -eqSpecPair :: EqSpec -> (TyVar, Type) -eqSpecPair (EqSpec tv ty) = (tv, ty) - -eqSpecPreds :: [EqSpec] -> ThetaType -eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty - | EqSpec tv ty <- spec ] - --- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec --- is mapped in the substitution, it is mapped to a type variable, not --- a full type. -substEqSpec :: TCvSubst -> EqSpec -> EqSpec -substEqSpec subst (EqSpec tv ty) - = EqSpec tv' (substTy subst ty) - where - tv' = getTyVar "substEqSpec" (substTyVar subst tv) - --- | Filter out any 'TyVar's mentioned in an 'EqSpec'. -filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] -filterEqSpec eq_spec - = filter not_in_eq_spec - where - not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec - -instance Outputable EqSpec where - ppr (EqSpec tv ty) = ppr (tv, ty) - -{- Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Int {-# UNPACK #-} !Int Bool - -When compiling the module, GHC will decide how to represent -MkT, depending on the optimisation level, and settings of -flags like -funbox-small-strict-fields. - -Terminology: - * HsSrcBang: What the user wrote - Constructors: HsSrcBang - - * HsImplBang: What GHC decided - Constructors: HsLazy, HsStrict, HsUnpack - -* If T was defined in this module, MkT's dcSrcBangs field - records the [HsSrcBang] of what the user wrote; in the example - [ HsSrcBang _ NoSrcUnpack SrcStrict - , HsSrcBang _ SrcUnpack SrcStrict - , HsSrcBang _ NoSrcUnpack NoSrcStrictness] - -* However, if T was defined in an imported module, the importing module - must follow the decisions made in the original module, regardless of - the flag settings in the importing module. - Also see Note [Bangs on imported data constructors] in MkId - -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be - [HsStrict, HsStrict, HsLazy] - With -O it might be - [HsStrict, HsUnpack _, HsLazy] - With -funbox-small-strict-fields it might be - [HsUnpack, HsUnpack _, HsLazy] - With -XStrictData it might be - [HsStrict, HsUnpack _, HsStrict] - -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -Here's an example illustrating both: - data Ord a => T a = MkT Int! a -Here - T :: Ord a => Int -> a -> T a -but the rep type is - Trep :: Int# -> a -> T a -Actually, the unboxed part isn't implemented yet! - - - -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq DataCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable DataCon where - getUnique = dcUnique - -instance NamedThing DataCon where - getName = dcName - -instance Outputable DataCon where - ppr con = ppr (dataConName con) - -instance OutputableBndr DataCon where - pprInfixOcc con = pprInfixName (dataConName con) - pprPrefixOcc con = pprPrefixName (dataConName con) - -instance Data.Data DataCon where - -- don't traverse? - toConstr _ = abstractConstr "DataCon" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "DataCon" - -instance Outputable HsSrcBang where - ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark - -instance Outputable HsImplBang where - ppr HsLazy = text "Lazy" - ppr (HsUnpack Nothing) = text "Unpacked" - ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) - ppr HsStrict = text "StrictNotUnpacked" - -instance Outputable SrcStrictness where - ppr SrcLazy = char '~' - ppr SrcStrict = char '!' - ppr NoSrcStrict = empty - -instance Outputable SrcUnpackedness where - ppr SrcUnpack = text "{-# UNPACK #-}" - ppr SrcNoUnpack = text "{-# NOUNPACK #-}" - ppr NoSrcUnpack = empty - -instance Outputable StrictnessMark where - ppr MarkedStrict = text "!" - ppr NotMarkedStrict = empty - -instance Binary SrcStrictness where - put_ bh SrcLazy = putByte bh 0 - put_ bh SrcStrict = putByte bh 1 - put_ bh NoSrcStrict = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcLazy - 1 -> return SrcStrict - _ -> return NoSrcStrict - -instance Binary SrcUnpackedness where - put_ bh SrcNoUnpack = putByte bh 0 - put_ bh SrcUnpack = putByte bh 1 - put_ bh NoSrcUnpack = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcNoUnpack - 1 -> return SrcUnpack - _ -> return NoSrcUnpack - --- | Compare strictness annotations -eqHsBang :: HsImplBang -> HsImplBang -> Bool -eqHsBang HsLazy HsLazy = True -eqHsBang HsStrict HsStrict = True -eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True -eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) - = eqType (coercionType c1) (coercionType c2) -eqHsBang _ _ = False - -isBanged :: HsImplBang -> Bool -isBanged (HsUnpack {}) = True -isBanged (HsStrict {}) = True -isBanged HsLazy = False - -isSrcStrict :: SrcStrictness -> Bool -isSrcStrict SrcStrict = True -isSrcStrict _ = False - -isSrcUnpacked :: SrcUnpackedness -> Bool -isSrcUnpacked SrcUnpack = True -isSrcUnpacked _ = False - -isMarkedStrict :: StrictnessMark -> Bool -isMarkedStrict NotMarkedStrict = False -isMarkedStrict _ = True -- All others are strict - -{- ********************************************************************* -* * -\subsection{Construction} -* * -********************************************************************* -} - --- | Build a new data constructor -mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyCoVar] -- ^ Existentials. - -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. - -- These must be Inferred/Specified. - -- See @Note [TyVarBinders in DataCons]@ - -> [EqSpec] -- ^ GADT equalities - -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper - -> [KnotTied Type] -- ^ Original argument types - -> KnotTied Type -- ^ Original result type - -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' - -> KnotTied TyCon -- ^ Representation type constructor - -> ConTag -- ^ Constructor tag - -> ThetaType -- ^ The "stupid theta", context of the data - -- declaration e.g. @data Eq a => T a ...@ - -> Id -- ^ Worker Id - -> DataConRep -- ^ Representation - -> DataCon - -- Can get the tag from the TyCon - -mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 - fields - univ_tvs ex_tvs user_tvbs - eq_spec theta - orig_arg_tys orig_res_ty rep_info rep_tycon tag - stupid_theta work_id rep --- Warning: mkDataCon is not a good place to check certain invariants. --- If the programmer writes the wrong result type in the decl, thus: --- data T a where { MkT :: S } --- then it's possible that the univ_tvs may hit an assertion failure --- if you pull on univ_tvs. This case is checked by checkValidDataCon, --- so the error is detected properly... it's just that assertions here --- are a little dodgy. - - = con - where - is_vanilla = null ex_tvs && null eq_spec && null theta - - con = MkData {dcName = name, dcUnique = nameUnique name, - dcVanilla = is_vanilla, dcInfix = declared_infix, - dcUnivTyVars = univ_tvs, - dcExTyCoVars = ex_tvs, - dcUserTyVarBinders = user_tvbs, - dcEqSpec = eq_spec, - dcOtherTheta = theta, - dcStupidTheta = stupid_theta, - dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, - dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, - dcFields = fields, dcTag = tag, dcRepType = rep_ty, - dcWorkId = work_id, - dcRep = rep, - dcSourceArity = length orig_arg_tys, - dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, - dcPromoted = promoted } - - -- The 'arg_stricts' passed to mkDataCon are simply those for the - -- source-language arguments. We add extra ones for the - -- dictionary arguments right here. - - rep_arg_tys = dataConRepArgTys con - - rep_ty = - case rep of - -- If the DataCon has no wrapper, then the worker's type *is* the - -- user-facing type, so we can simply use dataConUserType. - NoDataConRep -> dataConUserType con - -- If the DataCon has a wrapper, then the worker's type is never seen - -- by the user. The visibilities we pick do not matter here. - DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ - mkVisFunTys rep_arg_tys $ - mkTyConApp rep_tycon (mkTyVarTys univ_tvs) - - -- See Note [Promoted data constructors] in TyCon - prom_tv_bndrs = [ mkNamedTyConBinder vis tv - | Bndr tv vis <- user_tvbs ] - - fresh_names = freshNames (map getName user_tvbs) - -- fresh_names: make sure that the "anonymous" tyvars don't - -- clash in name or unique with the universal/existential ones. - -- Tiresome! And unnecessary because these tyvars are never looked at - prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) - {- Invisible -} | (n,t) <- fresh_names `zip` theta ] - prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) - {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] - prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs - prom_res_kind = orig_res_ty - promoted = mkPromotedDataCon con name prom_info prom_bndrs - prom_res_kind roles rep_info - - roles = map (\tv -> if isTyVar tv then Nominal else Phantom) - (univ_tvs ++ ex_tvs) - ++ map (const Representational) (theta ++ orig_arg_tys) - -freshNames :: [Name] -> [Name] --- Make an infinite list of Names whose Uniques and OccNames --- differ from those in the 'avoid' list -freshNames avoids - = [ mkSystemName uniq occ - | n <- [0..] - , let uniq = mkAlphaTyVarUnique n - occ = mkTyVarOccFS (mkFastString ('x' : show n)) - - , not (uniq `elementOfUniqSet` avoid_uniqs) - , not (occ `elemOccSet` avoid_occs) ] - - where - avoid_uniqs :: UniqSet Unique - avoid_uniqs = mkUniqSet (map getUnique avoids) - - avoid_occs :: OccSet - avoid_occs = mkOccSet (map getOccName avoids) - --- | The 'Name' of the 'DataCon', giving it a unique, rooted identification -dataConName :: DataCon -> Name -dataConName = dcName - --- | The tag used for ordering 'DataCon's -dataConTag :: DataCon -> ConTag -dataConTag = dcTag - -dataConTagZ :: DataCon -> ConTagZ -dataConTagZ con = dataConTag con - fIRST_TAG - --- | The type constructor that we are building via this data constructor -dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcRepTyCon - --- | The original type constructor used in the definition of this data --- constructor. In case of a data family instance, that will be the family --- type constructor. -dataConOrigTyCon :: DataCon -> TyCon -dataConOrigTyCon dc - | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc - | otherwise = dcRepTyCon dc - --- | The representation type of the data constructor, i.e. the sort --- type that will represent values of this type at runtime -dataConRepType :: DataCon -> Type -dataConRepType = dcRepType - --- | Should the 'DataCon' be presented infix? -dataConIsInfix :: DataCon -> Bool -dataConIsInfix = dcInfix - --- | The universally-quantified type variables of the constructor -dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs - --- | The existentially-quantified type/coercion variables of the constructor --- including dependent (kind-) GADT equalities -dataConExTyCoVars :: DataCon -> [TyCoVar] -dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs - --- | Both the universal and existential type/coercion variables of the constructor -dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] -dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) - = univ_tvs ++ ex_tvs - --- See Note [DataCon user type variable binders] --- | The type variables of the constructor, in the order the user wrote them -dataConUserTyVars :: DataCon -> [TyVar] -dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs - --- See Note [DataCon user type variable binders] --- | 'TyCoVarBinder's for the type variables of the constructor, in the order the --- user wrote them -dataConUserTyVarBinders :: DataCon -> [TyVarBinder] -dataConUserTyVarBinders = dcUserTyVarBinders - --- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration. This includes *all* GADT-like --- equalities, including those written in by hand by the programmer. -dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = dataConKindEqSpec con - ++ eq_spec ++ - [ spec -- heterogeneous equality - | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` heqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] ++ - [ spec -- homogeneous equality - | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` eqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] - --- | Dependent (kind-level) equalities in a constructor. --- There are extracted from the existential variables. --- See Note [Existential coercion variables] -dataConKindEqSpec :: DataCon -> [EqSpec] -dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) - -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), - -- which are frequently used functions. - -- For now (Aug 2018) this function always return empty set as we don't really - -- have coercion variables. - -- In the future when we do, we might want to cache this information in DataCon - -- so it won't be computed every time when aforementioned functions are called. - = [ EqSpec tv ty - | cv <- ex_tcvs - , isCoVar cv - , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv - tv = getTyVar "dataConKindEqSpec" ty1 - ] - --- | The *full* constraints on the constructor type, including dependent GADT --- equalities. -dataConTheta :: DataCon -> ThetaType -dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta - --- | Get the Id of the 'DataCon' worker: a function that is the "actual" --- constructor and has no top level binding in the program. The type may --- be different from the obvious one written in the source program. Panics --- if there is no such 'Id' for this 'DataCon' -dataConWorkId :: DataCon -> Id -dataConWorkId dc = dcWorkId dc - --- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" --- constructor so it has the type visible in the source program: c.f. --- 'dataConWorkId'. --- Returns Nothing if there is no wrapper, which occurs for an algebraic data --- constructor and also for a newtype (whose constructor is inlined --- compulsorily) -dataConWrapId_maybe :: DataCon -> Maybe Id -dataConWrapId_maybe dc = case dcRep dc of - NoDataConRep -> Nothing - DCR { dcr_wrap_id = wrap_id } -> Just wrap_id - --- | Returns an Id which looks like the Haskell-source constructor by using --- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to --- the worker (see 'dataConWorkId') -dataConWrapId :: DataCon -> Id -dataConWrapId dc = case dcRep dc of - NoDataConRep-> dcWorkId dc -- worker=wrapper - DCR { dcr_wrap_id = wrap_id } -> wrap_id - --- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, --- the union of the 'dataConWorkId' and the 'dataConWrapId' -dataConImplicitTyThings :: DataCon -> [TyThing] -dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) - = [AnId work] ++ wrap_ids - where - wrap_ids = case rep of - NoDataConRep -> [] - DCR { dcr_wrap_id = wrap } -> [AnId wrap] - --- | The labels for the fields of this particular 'DataCon' -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels = dcFields - --- | Extract the type for any given labelled field of the 'DataCon' -dataConFieldType :: DataCon -> FieldLabelString -> Type -dataConFieldType con label = case dataConFieldType_maybe con label of - Just (_, ty) -> ty - Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) - --- | Extract the label and type for any given labelled field of the --- 'DataCon', or return 'Nothing' if the field does not belong to it -dataConFieldType_maybe :: DataCon -> FieldLabelString - -> Maybe (FieldLabel, Type) -dataConFieldType_maybe con label - = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) - --- | Strictness/unpack annotations, from user; or, for imported --- DataCons, from the interface file --- The list is in one-to-one correspondence with the arity of the 'DataCon' - -dataConSrcBangs :: DataCon -> [HsSrcBang] -dataConSrcBangs = dcSrcBangs - --- | Source-level arity of the data constructor -dataConSourceArity :: DataCon -> Arity -dataConSourceArity (MkData { dcSourceArity = arity }) = arity - --- | Gives the number of actual fields in the /representation/ of the --- data constructor. This may be more than appear in the source code; --- the extra ones are the existentially quantified dictionaries -dataConRepArity :: DataCon -> Arity -dataConRepArity (MkData { dcRepArity = arity }) = arity - --- | Return whether there are any argument types for this 'DataCon's original source type --- See Note [DataCon arities] -isNullarySrcDataCon :: DataCon -> Bool -isNullarySrcDataCon dc = dataConSourceArity dc == 0 - --- | Return whether there are any argument types for this 'DataCon's runtime representation type --- See Note [DataCon arities] -isNullaryRepDataCon :: DataCon -> Bool -isNullaryRepDataCon dc = dataConRepArity dc == 0 - -dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs - -dataConImplBangs :: DataCon -> [HsImplBang] --- The implementation decisions about the strictness/unpack of each --- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs - -dataConBoxer :: DataCon -> Maybe DataConBoxer -dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer -dataConBoxer _ = Nothing - -dataConInstSig - :: DataCon - -> [Type] -- Instantiate the *universal* tyvars with these types - -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials - -- theta and arg tys --- ^ Instantiate the universal tyvars of a data con, --- returning --- ( instantiated existentials --- , instantiated constraints including dependent GADT equalities --- which are *also* listed in the instantiated existentials --- , instantiated args) -dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs - , dcOrigArgTys = arg_tys }) - univ_tys - = ( ex_tvs' - , substTheta subst (dataConTheta con) - , substTys subst arg_tys) - where - univ_subst = zipTvSubst univ_tvs univ_tys - (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs - - --- | The \"full signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConUnivTyVars' --- --- 2) The result of 'dataConExTyCoVars' --- --- 3) The non-dependent GADT equalities. --- Dependent GADT equalities are implied by coercion variables in --- return value (2). --- --- 4) The other constraints of the data constructor type, excluding GADT --- equalities --- --- 5) The original argument types to the 'DataCon' (i.e. before --- any change of the representation of the type) --- --- 6) The original result type of the 'DataCon' -dataConFullSig :: DataCon - -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, - dcEqSpec = eq_spec, dcOtherTheta = theta, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) - -dataConOrigResTy :: DataCon -> Type -dataConOrigResTy dc = dcOrigResTy dc - --- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: --- --- > data Eq a => T a = ... -dataConStupidTheta :: DataCon -> ThetaType -dataConStupidTheta dc = dcStupidTheta dc - -dataConUserType :: DataCon -> Type --- ^ The user-declared type of the data constructor --- in the nice-to-read form: --- --- > T :: forall a b. a -> b -> T [a] --- --- rather than: --- --- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c --- --- The type variables are quantified in the order that the user wrote them. --- See @Note [DataCon user type variable binders]@. --- --- NB: If the constructor is part of a data instance, the result type --- mentions the family tycon, not the internal one. -dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, - dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) - = mkForAllTys user_tvbs $ - mkInvisFunTys theta $ - mkVisFunTys arg_tys $ - res_ty - --- | Finds the instantiated types of the arguments required to construct a --- 'DataCon' representation --- NB: these INCLUDE any dictionary args --- but EXCLUDE the data-declaration context, which is discarded --- It's all post-flattening etc; this is a representation type -dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints - -- However, it can have a dcTheta (notably it can be a - -- class dictionary, with superclasses) - -> [Type] -- ^ Instantiated at these types - -> [Type] -dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, - dcExTyCoVars = ex_tvs}) inst_tys - = ASSERT2( univ_tvs `equalLength` inst_tys - , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) - ASSERT2( null ex_tvs, ppr dc ) - map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) - --- | Returns just the instantiated /value/ argument types of a 'DataCon', --- (excluding dictionary args) -dataConInstOrigArgTys - :: DataCon -- Works for any DataCon - -> [Type] -- Includes existential tyvar args, but NOT - -- equality constraints or dicts - -> [Type] --- For vanilla datacons, it's all quite straightforward --- But for the call in GHC.HsToCore.Match.Constructor, we really do want just --- the value args -dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyCoVars = ex_tvs}) inst_tys - = ASSERT2( tyvars `equalLength` inst_tys - , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTy subst) arg_tys - where - tyvars = univ_tvs ++ ex_tvs - subst = zipTCvSubst tyvars inst_tys - --- | Returns the argument types of the wrapper, excluding all dictionary arguments --- and without substituting for any type variables -dataConOrigArgTys :: DataCon -> [Type] -dataConOrigArgTys dc = dcOrigArgTys dc - --- | Returns the arg types of the worker, including *all* non-dependent --- evidence, after any flattening has been done and without substituting for --- any type variables -dataConRepArgTys :: DataCon -> [Type] -dataConRepArgTys (MkData { dcRep = rep - , dcEqSpec = eq_spec - , dcOtherTheta = theta - , dcOrigArgTys = orig_arg_tys }) - = case rep of - NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys - DCR { dcr_arg_tys = arg_tys } -> arg_tys - --- | The string @package:module.name@ identifying a constructor, which is attached --- to its info table and used by the GHCi debugger and the heap profiler -dataConIdentity :: DataCon -> ByteString --- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. -dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat - [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) - , BSB.int8 $ fromIntegral (ord ':') - , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) - , BSB.int8 $ fromIntegral (ord '.') - , BSB.byteString $ bytesFS (occNameFS (nameOccName name)) - ] - where name = dataConName dc - mod = ASSERT( isExternalName name ) nameModule name - -isTupleDataCon :: DataCon -> Bool -isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc - -isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc - -isUnboxedSumCon :: DataCon -> Bool -isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc - --- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors -isVanillaDataCon :: DataCon -> Bool -isVanillaDataCon dc = dcVanilla dc - --- | Should this DataCon be allowed in a type even without -XDataKinds? --- Currently, only Lifted & Unlifted -specialPromotedDc :: DataCon -> Bool -specialPromotedDc = isKindTyCon . dataConTyCon - -classDataCon :: Class -> DataCon -classDataCon clas = case tyConDataCons (classTyCon clas) of - (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr - [] -> panic "classDataCon" - -dataConCannotMatch :: [Type] -> DataCon -> Bool --- Returns True iff the data con *definitely cannot* match a --- scrutinee of type (T tys) --- where T is the dcRepTyCon for the data con -dataConCannotMatch tys con - -- See (U6) in Note [Implementing unsafeCoerce] - -- in base:Unsafe.Coerce - | dataConName con == unsafeReflDataConName - = False - | null inst_theta = False -- Common - | all isTyVarTy tys = False -- Also common - | otherwise = typesCantMatch (concatMap predEqs inst_theta) - where - (_, inst_theta, _) = dataConInstSig con tys - - -- TODO: could gather equalities from superclasses too - predEqs pred = case classifyPredType pred of - EqPred NomEq ty1 ty2 -> [(ty1, ty2)] - ClassPred eq args - | eq `hasKey` eqTyConKey - , [_, ty1, ty2] <- args -> [(ty1, ty2)] - | eq `hasKey` heqTyConKey - , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] - _ -> [] - --- | Were the type variables of the data con written in a different order --- than the regular order (universal tyvars followed by existential tyvars)? --- --- This is not a cheap test, so we minimize its use in GHC as much as possible. --- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in --- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once --- during a data constructor's lifetime. - --- See Note [DataCon user type variable binders], as well as --- Note [Data con wrappers and GADT syntax] for an explanation of what --- mkDataConRep is doing with this function. -dataConUserTyVarsArePermuted :: DataCon -> Bool -dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs - , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec - , dcUserTyVarBinders = user_tvbs }) = - (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs - -{- -%************************************************************************ -%* * - Promoting of data types to the kind level -* * -************************************************************************ - --} - -promoteDataCon :: DataCon -> TyCon -promoteDataCon (MkData { dcPromoted = tc }) = tc - -{- -************************************************************************ -* * -\subsection{Splitting products} -* * -************************************************************************ --} - --- | Extract the type constructor, type argument, data constructor and it's --- /representation/ argument types from a type if it is a product type. --- --- Precisely, we return @Just@ for any type that is all of: --- --- * Concrete (i.e. constructors visible) --- --- * Single-constructor --- --- * Not existentially quantified --- --- Whether the type is a @data@ type or a @newtype@ -splitDataProductType_maybe - :: Type -- ^ A product type, perhaps - -> Maybe (TyCon, -- The type constructor - [Type], -- Type args of the tycon - DataCon, -- The data constructor - [Type]) -- Its /representation/ arg types - - -- Rejecting existentials is conservative. Maybe some things - -- could be made to work with them, but I'm not going to sweat - -- it through till someone finds it's important. - -splitDataProductType_maybe ty - | Just (tycon, ty_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tycon - = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) - | otherwise - = Nothing - diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ /dev/null @@ -1,34 +0,0 @@ -module DataCon where - -import GhcPrelude -import Var( TyVar, TyCoVar, TyVarBinder ) -import Name( Name, NamedThing ) -import {-# SOURCE #-} TyCon( TyCon ) -import FieldLabel ( FieldLabel ) -import Unique ( Uniquable ) -import Outputable ( Outputable, OutputableBndr ) -import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) - -data DataCon -data DataConRep -data EqSpec - -dataConName :: DataCon -> Name -dataConTyCon :: DataCon -> TyCon -dataConExTyCoVars :: DataCon -> [TyCoVar] -dataConUserTyVars :: DataCon -> [TyVar] -dataConUserTyVarBinders :: DataCon -> [TyVarBinder] -dataConSourceArity :: DataCon -> Arity -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] -dataConStupidTheta :: DataCon -> ThetaType -dataConFullSig :: DataCon - -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) -isUnboxedSumCon :: DataCon -> Bool - -instance Eq DataCon -instance Uniquable DataCon -instance NamedThing DataCon -instance Outputable DataCon -instance OutputableBndr DataCon diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs deleted file mode 100644 --- a/compiler/basicTypes/Demand.hs +++ /dev/null @@ -1,2005 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Demand]{@Demand@: A decoupled implementation of a demand domain} --} - -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Demand ( - StrDmd, UseDmd(..), Count, - - Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, - mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, - toCleanDmd, - absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, - lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, - isTopDmd, isAbsDmd, isSeqDmd, - peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, - addCaseBndrDmd, - - DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, - nopDmdType, botDmdType, mkDmdType, - addDemand, ensureArgs, - BothDmdArg, mkBothDmdArg, toBothDmdArg, - - DmdEnv, emptyDmdEnv, - peelFV, findIdDemand, - - Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv, - appIsBottom, isBottomingSig, pprIfaceStrictSig, - StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, - nopSig, botSig, cprProdSig, - isTopSig, hasDemandEnvSig, - splitStrictSig, strictSigDmdEnv, - increaseStrictSigArity, etaExpandStrictSig, - - seqDemand, seqDemandList, seqDmdType, seqStrictSig, - - evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, splitFVs, - deferAfterIO, - postProcessUnsat, postProcessDmdType, - - splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, - mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, - dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, - TypeShape(..), peelTsFuns, trimToType, - - useCount, isUsedOnce, reuseEnv, - killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig, - zapUsedOnceDemand, zapUsedOnceSig, - strictifyDictDmd, strictifyDmd - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import Outputable -import Var ( Var ) -import VarEnv -import UniqFM -import Util -import BasicTypes -import Binary -import Maybes ( orElse ) - -import Type ( Type ) -import TyCon ( isNewTyCon, isClassTyCon ) -import DataCon ( splitDataProductType_maybe ) - -{- -************************************************************************ -* * - Joint domain for Strictness and Absence -* * -************************************************************************ --} - -data JointDmd s u = JD { sd :: s, ud :: u } - deriving ( Eq, Show ) - -getStrDmd :: JointDmd s u -> s -getStrDmd = sd - -getUseDmd :: JointDmd s u -> u -getUseDmd = ud - --- Pretty-printing -instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where - ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) - --- Well-formedness preserving constructors for the joint domain -mkJointDmd :: s -> u -> JointDmd s u -mkJointDmd s u = JD { sd = s, ud = u } - -mkJointDmds :: [s] -> [u] -> [JointDmd s u] -mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as - - -{- -************************************************************************ -* * - Strictness domain -* * -************************************************************************ - - Lazy - | - HeadStr - / \ - SCall SProd - \ / - HyperStr - -Note [Exceptions and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to smart about catching exceptions, but we aren't anymore. -See #14998 for the way it's resolved at the moment. - -Here's a historic breakdown: - -Apparently, exception handling prim-ops didn't use to have any special -strictness signatures, thus defaulting to topSig, which assumes they use their -arguments lazily. Joachim was the first to realise that we could provide richer -information. Thus, in 0558911f91c (Dec 13), he added signatures to -primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call -their argument, which is useful information for usage analysis. Still with a -'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. - -In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a -'strictApply1Dmd' leads to substantial performance gains. That was at the cost -of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in -28638dfe79e (Dec 15). - -Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, -Ben opened #11222. Simon made the demand analyser "understand catch" in -9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call -its argument strictly, but also swallow any thrown exceptions in -'postProcessDivergence'. This was realized by extending the 'Str' constructor of -'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and -adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element -between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, -so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). - -This left the other variants like 'catchRetry#' having 'catchArgDmd', which is -where #14998 picked up. Item 1 was concerned with measuring the impact of also -making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that -there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 -(Apr 18). There was a lot of dead code resulting from that change, that we -removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and -removed any code that was dealing with the peculiarities. - -Where did the speed-ups vanish to? In #14998, item 3 established that -turning 'catch#' strict in its first argument didn't bring back any of the -alleged performance benefits. Item 2 of that ticket finally found out that it -was entirely due to 'catchException's new (since #11555) definition, which -was simply - - catchException !io handler = catch io handler - -While 'catchException' is arguably the saner semantics for 'catch', it is an -internal helper function in "GHC.IO". Its use in -"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: -Remove the bang and you find the regressions we originally wanted to avoid with -'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". - -So history keeps telling us that the only possibly correct strictness annotation -for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really -is not strict in its argument: Just try this in GHCi - - :set -XScopedTypeVariables - import Control.Exception - catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") - -Any analysis that assumes otherwise will be broken in some way or another -(beyond `-fno-pendantic-bottoms`). --} - --- | Vanilla strictness domain -data StrDmd - = HyperStr -- ^ Hyper-strict (bottom of the lattice). - -- See Note [HyperStr and Use demands] - - | SCall StrDmd -- ^ Call demand - -- Used only for values of function type - - | SProd [ArgStr] -- ^ Product - -- Used only for values of product type - -- Invariant: not all components are HyperStr (use HyperStr) - -- not all components are Lazy (use HeadStr) - - | HeadStr -- ^ Head-Strict - -- A polymorphic demand: used for values of all types, - -- including a type variable - - deriving ( Eq, Show ) - --- | Strictness of a function argument. -type ArgStr = Str StrDmd - --- | Strictness demand. -data Str s = Lazy -- ^ Lazy (top of the lattice) - | Str s -- ^ Strict - deriving ( Eq, Show ) - --- Well-formedness preserving constructors for the Strictness domain -strBot, strTop :: ArgStr -strBot = Str HyperStr -strTop = Lazy - -mkSCall :: StrDmd -> StrDmd -mkSCall HyperStr = HyperStr -mkSCall s = SCall s - -mkSProd :: [ArgStr] -> StrDmd -mkSProd sx - | any isHyperStr sx = HyperStr - | all isLazy sx = HeadStr - | otherwise = SProd sx - -isLazy :: ArgStr -> Bool -isLazy Lazy = True -isLazy (Str {}) = False - -isHyperStr :: ArgStr -> Bool -isHyperStr (Str HyperStr) = True -isHyperStr _ = False - --- Pretty-printing -instance Outputable StrDmd where - ppr HyperStr = char 'B' - ppr (SCall s) = char 'C' <> parens (ppr s) - ppr HeadStr = char 'S' - ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) - -instance Outputable ArgStr where - ppr (Str s) = ppr s - ppr Lazy = char 'L' - -lubArgStr :: ArgStr -> ArgStr -> ArgStr -lubArgStr Lazy _ = Lazy -lubArgStr _ Lazy = Lazy -lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) - -lubStr :: StrDmd -> StrDmd -> StrDmd -lubStr HyperStr s = s -lubStr (SCall s1) HyperStr = SCall s1 -lubStr (SCall _) HeadStr = HeadStr -lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) -lubStr (SCall _) (SProd _) = HeadStr -lubStr (SProd sx) HyperStr = SProd sx -lubStr (SProd _) HeadStr = HeadStr -lubStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) - | otherwise = HeadStr -lubStr (SProd _) (SCall _) = HeadStr -lubStr HeadStr _ = HeadStr - -bothArgStr :: ArgStr -> ArgStr -> ArgStr -bothArgStr Lazy s = s -bothArgStr s Lazy = s -bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) - -bothStr :: StrDmd -> StrDmd -> StrDmd -bothStr HyperStr _ = HyperStr -bothStr HeadStr s = s -bothStr (SCall _) HyperStr = HyperStr -bothStr (SCall s1) HeadStr = SCall s1 -bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) -bothStr (SCall _) (SProd _) = HyperStr -- Weird - -bothStr (SProd _) HyperStr = HyperStr -bothStr (SProd s1) HeadStr = SProd s1 -bothStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) - | otherwise = HyperStr -- Weird -bothStr (SProd _) (SCall _) = HyperStr - --- utility functions to deal with memory leaks -seqStrDmd :: StrDmd -> () -seqStrDmd (SProd ds) = seqStrDmdList ds -seqStrDmd (SCall s) = seqStrDmd s -seqStrDmd _ = () - -seqStrDmdList :: [ArgStr] -> () -seqStrDmdList [] = () -seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds - -seqArgStr :: ArgStr -> () -seqArgStr Lazy = () -seqArgStr (Str s) = seqStrDmd s - --- Splitting polymorphic demands -splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] -splitArgStrProdDmd n Lazy = Just (replicate n Lazy) -splitArgStrProdDmd n (Str s) = splitStrProdDmd n s - -splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] -splitStrProdDmd n HyperStr = Just (replicate n strBot) -splitStrProdDmd n HeadStr = Just (replicate n strTop) -splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), - text "splitStrProdDmd" $$ ppr n $$ ppr ds ) - Just ds -splitStrProdDmd _ (SCall {}) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -{- -************************************************************************ -* * - Absence domain -* * -************************************************************************ - - Used - / \ - UCall UProd - \ / - UHead - | - Count x - - | - Abs --} - --- | Domain for genuine usage -data UseDmd - = UCall Count UseDmd -- ^ Call demand for absence. - -- Used only for values of function type - - | UProd [ArgUse] -- ^ Product. - -- Used only for values of product type - -- See Note [Don't optimise UProd(Used) to Used] - -- - -- Invariant: Not all components are Abs - -- (in that case, use UHead) - - | UHead -- ^ May be used but its sub-components are - -- definitely *not* used. For product types, UHead - -- is equivalent to U(AAA); see mkUProd. - -- - -- UHead is needed only to express the demand - -- of 'seq' and 'case' which are polymorphic; - -- i.e. the scrutinised value is of type 'a' - -- rather than a product type. That's why we - -- can't use UProd [A,A,A] - -- - -- Since (UCall _ Abs) is ill-typed, UHead doesn't - -- make sense for lambdas - - | Used -- ^ May be used and its sub-components may be used. - -- (top of the lattice) - deriving ( Eq, Show ) - --- Extended usage demand for absence and counting -type ArgUse = Use UseDmd - -data Use u - = Abs -- Definitely unused - -- Bottom of the lattice - - | Use Count u -- May be used with some cardinality - deriving ( Eq, Show ) - --- | Abstract counting of usages -data Count = One | Many - deriving ( Eq, Show ) - --- Pretty-printing -instance Outputable ArgUse where - ppr Abs = char 'A' - ppr (Use Many a) = ppr a - ppr (Use One a) = char '1' <> char '*' <> ppr a - -instance Outputable UseDmd where - ppr Used = char 'U' - ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) - ppr UHead = char 'H' - ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) - -instance Outputable Count where - ppr One = char '1' - ppr Many = text "" - -useBot, useTop :: ArgUse -useBot = Abs -useTop = Use Many Used - -mkUCall :: Count -> UseDmd -> UseDmd ---mkUCall c Used = Used c -mkUCall c a = UCall c a - -mkUProd :: [ArgUse] -> UseDmd -mkUProd ux - | all (== Abs) ux = UHead - | otherwise = UProd ux - -lubCount :: Count -> Count -> Count -lubCount _ Many = Many -lubCount Many _ = Many -lubCount x _ = x - -lubArgUse :: ArgUse -> ArgUse -> ArgUse -lubArgUse Abs x = x -lubArgUse x Abs = x -lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) - -lubUse :: UseDmd -> UseDmd -> UseDmd -lubUse UHead u = u -lubUse (UCall c u) UHead = UCall c u -lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) -lubUse (UCall _ _) _ = Used -lubUse (UProd ux) UHead = UProd ux -lubUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 - | otherwise = Used -lubUse (UProd {}) (UCall {}) = Used --- lubUse (UProd {}) Used = Used -lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) -lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) -lubUse Used _ = Used -- Note [Used should win] - --- `both` is different from `lub` in its treatment of counting; if --- `both` is computed for two used, the result always has --- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). --- Also, x `bothUse` x /= x (for anything but Abs). - -bothArgUse :: ArgUse -> ArgUse -> ArgUse -bothArgUse Abs x = x -bothArgUse x Abs = x -bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) - - -bothUse :: UseDmd -> UseDmd -> UseDmd -bothUse UHead u = u -bothUse (UCall c u) UHead = UCall c u - --- Exciting special treatment of inner demand for call demands: --- use `lubUse` instead of `bothUse`! -bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) - -bothUse (UCall {}) _ = Used -bothUse (UProd ux) UHead = UProd ux -bothUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 - | otherwise = Used -bothUse (UProd {}) (UCall {}) = Used --- bothUse (UProd {}) Used = Used -- Note [Used should win] -bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) -bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) -bothUse Used _ = Used -- Note [Used should win] - -peelUseCall :: UseDmd -> Maybe (Count, UseDmd) -peelUseCall (UCall c u) = Just (c,u) -peelUseCall _ = Nothing - -addCaseBndrDmd :: Demand -- On the case binder - -> [Demand] -- On the components of the constructor - -> [Demand] -- Final demands for the components of the constructor --- See Note [Demand on case-alternative binders] -addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds - = case mu of - Abs -> alt_dmds - Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) - where - Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call - Just us = splitUseProdDmd arity u -- Ditto - where - arity = length alt_dmds - -{- Note [Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand on a binder in a case alternative comes - (a) From the demand on the binder itself - (b) From the demand on the case binder -Forgetting (b) led directly to #10148. - -Example. Source code: - f x@(p,_) = if p then foo x else True - - foo (p,True) = True - foo (p,q) = foo (q,p) - -After strictness analysis: - f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> - case x_an1 - of wild_X7 [Dmd=] - { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> - case p_an2 of _ { - False -> GHC.Types.True; - True -> foo wild_X7 } - -It's true that ds_dnz is *itself* absent, but the use of wild_X7 means -that it is very much alive and demanded. See #10148 for how the -consequences play out. - -This is needed even for non-product types, in case the case-binder -is used but the components of the case alternative are not. - -Note [Don't optimise UProd(Used) to Used] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two UseDmds: - UProd [Used, Used] and Used -are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Suppose we did. -then - f (x,y) = (y,x) -would get - StrDmd = Str = SProd [Lazy, Lazy] - UseDmd = Used = UProd [Used, Used] -But with the joint demand of doesn't convey any clue -that there is a product involved, and so the worthSplittingFun -will not fire. (We'd need to use the type as well to make it fire.) -Moreover, consider - g h p@(_,_) = h p -This too would get , but this time there really isn't any -point in w/w since the components of the pair are not used at all. - -So the solution is: don't aggressively collapse UProd [Used,Used] to -Used; instead leave it as-is. In effect we are using the UseDmd to do a -little bit of boxity analysis. Not very nice. - -Note [Used should win] -~~~~~~~~~~~~~~~~~~~~~~ -Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. -Why? Because Used carries the implication the whole thing is used, -box and all, so we don't want to w/w it. If we use it both boxed and -unboxed, then we are definitely using the box, and so we are quite -likely to pay a reboxing cost. So we make Used win here. - -Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer - -Baseline: (A) Not making Used win (UProd wins) -Compare with: (B) making Used win for lub and both - - Min -0.3% -5.6% -10.7% -11.0% -33.3% - Max +0.3% +45.6% +11.5% +11.5% +6.9% - Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% - -Baseline: (B) Making Used win for both lub and both -Compare with: (C) making Used win for both, but UProd win for lub - - Min -0.1% -0.3% -7.9% -8.0% -6.5% - Max +0.1% +1.0% +21.0% +21.0% +0.5% - Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% --} - --- If a demand is used multiple times (i.e. reused), than any use-once --- mentioned there, that is not protected by a UCall, can happen many times. -markReusedDmd :: ArgUse -> ArgUse -markReusedDmd Abs = Abs -markReusedDmd (Use _ a) = Use Many (markReused a) - -markReused :: UseDmd -> UseDmd -markReused (UCall _ u) = UCall Many u -- No need to recurse here -markReused (UProd ux) = UProd (map markReusedDmd ux) -markReused u = u - -isUsedMU :: ArgUse -> Bool --- True <=> markReusedDmd d = d -isUsedMU Abs = True -isUsedMU (Use One _) = False -isUsedMU (Use Many u) = isUsedU u - -isUsedU :: UseDmd -> Bool --- True <=> markReused d = d -isUsedU Used = True -isUsedU UHead = True -isUsedU (UProd us) = all isUsedMU us -isUsedU (UCall One _) = False -isUsedU (UCall Many _) = True -- No need to recurse - --- Squashing usage demand demands -seqUseDmd :: UseDmd -> () -seqUseDmd (UProd ds) = seqArgUseList ds -seqUseDmd (UCall c d) = c `seq` seqUseDmd d -seqUseDmd _ = () - -seqArgUseList :: [ArgUse] -> () -seqArgUseList [] = () -seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds - -seqArgUse :: ArgUse -> () -seqArgUse (Use c u) = c `seq` seqUseDmd u -seqArgUse _ = () - --- Splitting polymorphic Maybe-Used demands -splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] -splitUseProdDmd n Used = Just (replicate n useTop) -splitUseProdDmd n UHead = Just (replicate n Abs) -splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), - text "splitUseProdDmd" $$ ppr n - $$ ppr ds ) - Just ds -splitUseProdDmd _ (UCall _ _) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -useCount :: Use u -> Count -useCount Abs = One -useCount (Use One _) = One -useCount _ = Many - - -{- -************************************************************************ -* * - Clean demand for Strictness and Usage -* * -************************************************************************ - -This domain differst from JointDemand in the sense that pure absence -is taken away, i.e., we deal *only* with non-absent demands. - -Note [Strict demands] -~~~~~~~~~~~~~~~~~~~~~ -isStrictDmd returns true only of demands that are - both strict - and used -In particular, it is False for , which can and does -arise in, say (#7319) - f x = raise# -Then 'x' is not used, so f gets strictness -> . -Now the w/w generates - fx = let x = absentError "unused" - in raise -At this point we really don't want to convert to - fx = case absentError "unused" of x -> raise -Since the program is going to diverge, this swaps one error for another, -but it's really a bad idea to *ever* evaluate an absent argument. -In #7319 we get - T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] - -Note [Dealing with call demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Call demands are constructed and deconstructed coherently for -strictness and absence. For instance, the strictness signature for the -following function - -f :: (Int -> (Int, Int)) -> (Int, Bool) -f g = (snd (g 3), True) - -should be: m --} - -type CleanDemand = JointDmd StrDmd UseDmd - -- A demand that is at least head-strict - -bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand -bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) - = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } - -mkHeadStrict :: CleanDemand -> CleanDemand -mkHeadStrict cd = cd { sd = HeadStr } - -mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand -mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } -mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } - -evalDmd :: Demand --- Evaluated strictly, and used arbitrarily deeply -evalDmd = JD { sd = Str HeadStr, ud = useTop } - -mkProdDmd :: [Demand] -> CleanDemand -mkProdDmd dx - = JD { sd = mkSProd $ map getStrDmd dx - , ud = mkUProd $ map getUseDmd dx } - --- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. -mkCallDmd :: CleanDemand -> CleanDemand -mkCallDmd (JD {sd = d, ud = u}) - = JD { sd = mkSCall d, ud = mkUCall One u } - --- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. -mkCallDmds :: Arity -> CleanDemand -> CleanDemand -mkCallDmds arity cd = iterate mkCallDmd cd !! arity - --- See Note [Demand on the worker] in WorkWrap -mkWorkerDemand :: Int -> Demand -mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } - where go 0 = Used - go n = mkUCall One $ go (n-1) - -cleanEvalDmd :: CleanDemand -cleanEvalDmd = JD { sd = HeadStr, ud = Used } - -cleanEvalProdDmd :: Arity -> CleanDemand -cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } - - -{- -************************************************************************ -* * - Demand: Combining Strictness and Usage -* * -************************************************************************ --} - -type Demand = JointDmd ArgStr ArgUse - -lubDmd :: Demand -> Demand -> Demand -lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `lubArgStr` s2 - , ud = a1 `lubArgUse` a2 } - -bothDmd :: Demand -> Demand -> Demand -bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `bothArgStr` s2 - , ud = a1 `bothArgUse` a2 } - -lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand - -strictApply1Dmd = JD { sd = Str (SCall HeadStr) - , ud = Use Many (UCall One Used) } - -lazyApply1Dmd = JD { sd = Lazy - , ud = Use One (UCall One Used) } - --- Second argument of catch#: --- uses its arg at most once, applies it once --- but is lazy (might not be called at all) -lazyApply2Dmd = JD { sd = Lazy - , ud = Use One (UCall One (UCall One Used)) } - -absDmd :: Demand -absDmd = JD { sd = Lazy, ud = Abs } - -topDmd :: Demand -topDmd = JD { sd = Lazy, ud = useTop } - -botDmd :: Demand -botDmd = JD { sd = strBot, ud = useBot } - -seqDmd :: Demand -seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } - -oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) -oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } -oneifyDmd jd = jd - -isTopDmd :: Demand -> Bool --- Used to suppress pretty-printing of an uninformative demand -isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True -isTopDmd _ = False - -isAbsDmd :: JointDmd (Str s) (Use u) -> Bool -isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr -isAbsDmd _ = False -- for a bottom demand - -isSeqDmd :: Demand -> Bool -isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True -isSeqDmd _ = False - -isUsedOnce :: JointDmd (Str s) (Use u) -> Bool -isUsedOnce (JD { ud = a }) = case useCount a of - One -> True - Many -> False - --- More utility functions for strictness -seqDemand :: Demand -> () -seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -isStrictDmd :: JointDmd (Str s) (Use u) -> Bool --- See Note [Strict demands] -isStrictDmd (JD {ud = Abs}) = False -isStrictDmd (JD {sd = Lazy}) = False -isStrictDmd _ = True - -isWeakDmd :: Demand -> Bool -isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a - -cleanUseDmd_maybe :: Demand -> Maybe UseDmd -cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u -cleanUseDmd_maybe _ = Nothing - -splitFVs :: Bool -- Thunk - -> DmdEnv -> (DmdEnv, DmdEnv) -splitFVs is_thunk rhs_fvs - | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs - -- It's OK to use nonDetFoldUFM_Directly because we - -- immediately forget the ordering by putting the elements - -- in the envs again - | otherwise = partitionVarEnv isWeakDmd rhs_fvs - where - add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) - | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) - | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) - , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) - -data TypeShape = TsFun TypeShape - | TsProd [TypeShape] - | TsUnk - -instance Outputable TypeShape where - ppr TsUnk = text "TsUnk" - ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) - ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) - --- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and --- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. -peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape -peelTsFuns 0 ts = Just ts -peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts -peelTsFuns _ _ = Nothing - -trimToType :: Demand -> TypeShape -> Demand --- See Note [Trimming a demand to a type] -trimToType (JD { sd = ms, ud = mu }) ts - = JD (go_ms ms ts) (go_mu mu ts) - where - go_ms :: ArgStr -> TypeShape -> ArgStr - go_ms Lazy _ = Lazy - go_ms (Str s) ts = Str (go_s s ts) - - go_s :: StrDmd -> TypeShape -> StrDmd - go_s HyperStr _ = HyperStr - go_s (SCall s) (TsFun ts) = SCall (go_s s ts) - go_s (SProd mss) (TsProd tss) - | equalLength mss tss = SProd (zipWith go_ms mss tss) - go_s _ _ = HeadStr - - go_mu :: ArgUse -> TypeShape -> ArgUse - go_mu Abs _ = Abs - go_mu (Use c u) ts = Use c (go_u u ts) - - go_u :: UseDmd -> TypeShape -> UseDmd - go_u UHead _ = UHead - go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) - go_u (UProd mus) (TsProd tss) - | equalLength mus tss = UProd (zipWith go_mu mus tss) - go_u _ _ = Used - -{- -Note [Trimming a demand to a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f :: a -> Bool - f x = case ... of - A g1 -> case (x |> g1) of (p,q) -> ... - B -> error "urk" - -where A,B are the constructors of a GADT. We'll get a U(U,U) demand -on x from the A branch, but that's a stupid demand for x itself, which -has type 'a'. Indeed we get ASSERTs going off (notably in -splitUseProdDmd, #8569). - -Bottom line: we really don't want to have a binder whose demand is more -deeply-nested than its type. There are various ways to tackle this. -When processing (x |> g1), we could "trim" the incoming demand U(U,U) -to match x's type. But I'm currently doing so just at the moment when -we pin a demand on a binder, in DmdAnal.findBndrDmd. - - -Note [Threshold demands] -~~~~~~~~~~~~~~~~~~~~~~~~ -Threshold usage demand is generated to figure out if -cardinality-instrumented demands of a binding's free variables should -be unleashed. See also [Aggregated demand for cardinality]. - -Note [Replicating polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some demands can be considered as polymorphic. Generally, it is -applicable to such beasts as tops, bottoms as well as Head-Used and -Head-stricts demands. For instance, - -S ~ S(L, ..., L) - -Also, when top or bottom is occurred as a result demand, it in fact -can be expanded to saturate a callee's arity. --} - -splitProdDmd_maybe :: Demand -> Maybe [Demand] --- Split a product into its components, iff there is any --- useful information to be extracted thereby --- The demand is not necessarily strict! -splitProdDmd_maybe (JD { sd = s, ud = u }) - = case (s,u) of - (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u - -> Just (mkJointDmds sx ux) - (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s - -> Just (mkJointDmds sx ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing - -{- -************************************************************************ -* * - Termination -* * -************************************************************************ - -Divergence: Dunno - / - Diverges - -In a fixpoint iteration, start from Diverges --} - -data Divergence - = Diverges -- Definitely diverges - | Dunno -- Might diverge or converge - deriving( Eq, Show ) - -lubDivergence :: Divergence -> Divergence ->Divergence -lubDivergence Diverges r = r -lubDivergence r Diverges = r -lubDivergence Dunno Dunno = Dunno --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -bothDivergence :: Divergence -> Divergence -> Divergence --- See Note [Asymmetry of 'both' for DmdType and Divergence] -bothDivergence _ Diverges = Diverges -bothDivergence r Dunno = r --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -instance Outputable Divergence where - ppr Diverges = char 'b' - ppr Dunno = empty - ------------------------------------------------------------------------- --- Combined demand result -- ------------------------------------------------------------------------- - --- [cprRes] lets us switch off CPR analysis --- by making sure that everything uses TopRes -topDiv, botDiv :: Divergence -topDiv = Dunno -botDiv = Diverges - -isTopDiv :: Divergence -> Bool -isTopDiv Dunno = True -isTopDiv _ = False - --- | True if the result diverges or throws an exception -isBotDiv :: Divergence -> Bool -isBotDiv Diverges = True -isBotDiv _ = False - --- See Notes [Default demand on free variables] --- and [defaultDmd vs. resTypeArgDmd] -defaultDmd :: Divergence -> Demand -defaultDmd Dunno = absDmd -defaultDmd _ = botDmd -- Diverges - -resTypeArgDmd :: Divergence -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes === (Bot -> BotRes) === ... --- TopRes === (Top -> TopRes) === ... --- This function makes that concrete --- Also see Note [defaultDmd vs. resTypeArgDmd] -resTypeArgDmd Dunno = topDmd -resTypeArgDmd _ = botDmd -- Diverges - -{- -Note [defaultDmd and resTypeArgDmd] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -These functions are similar: They express the demand on something not -explicitly mentioned in the environment resp. the argument list. Yet they are -different: - * Variables not mentioned in the free variables environment are definitely - unused, so we can use absDmd there. - * Further arguments *can* be used, of course. Hence topDmd is used. - - -************************************************************************ -* * - Demand environments and types -* * -************************************************************************ --} - -type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] - -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - Divergence -- See [Nature of result demand] - -{- -Note [Nature of result demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Divergence contains information about termination (currently distinguishing -definite divergence and no information; it is possible to include definite -convergence here), and CPR information about the result. - -The semantics of this depends on whether we are looking at a DmdType, i.e. the -demand put on by an expression _under a specific incoming demand_ on its -environment, or at a StrictSig describing a demand transformer. - -For a - * DmdType, the termination information is true given the demand it was - generated with, while for - * a StrictSig it holds after applying enough arguments. - -The CPR information, though, is valid after the number of arguments mentioned -in the type is given. Therefore, when forgetting the demand on arguments, as in -dmdAnalRhs, this needs to be considered (via removeDmdTyArgs). - -Consider - b2 x y = x `seq` y `seq` error (show x) -this has a strictness signature of - b -meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but -for "b2 1 2 `seq` ()" we get definite divergence. - -For comparison, - b1 x = x `seq` error (show x) -has a strictness signature of - b -and "b1 1 `seq` ()" is known to terminate. - -Now consider a function h with signature "", and the expression - e1 = h b1 -now h puts a demand of onto its argument, and the demand transformer -turns it into - b -Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not -diverge, and we do not anything being passed to b. - -Note [Asymmetry of 'both' for DmdType and Divergence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'both' for DmdTypes is *asymmetrical*, because there is only one -result! For example, given (e1 e2), we get a DmdType dt1 for e1, use -its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). -Similarly with - case e of { p -> rhs } -we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then -compute (dt_rhs `bothType` dt_scrut). - -We - 1. combine the information on the free variables, - 2. take the demand on arguments from the first argument - 3. combine the termination results, but - 4. take CPR info from the first argument. - -3 and 4 are implemented in bothDivergence. --} - --- Equality needed for fixpoints in DmdAnal -instance Eq DmdType where - (==) (DmdType fv1 ds1 div1) - (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 - -- It's OK to use nonDetUFMToList here because we're testing for - -- equality and even though the lists will be in some arbitrary - -- Unique order, it is the same order for both - && ds1 == ds2 && div1 == div2 - -lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 - = DmdType lub_fv lub_ds lub_div - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1 r1) = ensureArgs n d1 - (DmdType fv2 ds2 r2) = ensureArgs n d2 - - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) - lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_div = lubDivergence r1 r2 - -{- -Note [The need for BothDmdArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, the right argument to bothDmdType, as well as the return value of -dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs -to know about the free variables and termination information, but nothing about -the demand put on arguments, nor cpr information. So we make that explicit by -only passing the relevant information. --} - -type BothDmdArg = (DmdEnv, Divergence) - -mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, Dunno) - -toBothDmdArg :: DmdType -> BothDmdArg -toBothDmdArg (DmdType fv _ r) = (fv, go r) - where - go Dunno = Dunno - go Diverges = Diverges - -bothDmdType :: DmdType -> BothDmdArg -> DmdType -bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both' for DmdType and Divergence] - -- 'both' takes the argument/result info from its *first* arg, - -- using its second arg just for its free-var info. - = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) - ds1 - (r1 `bothDivergence` t2) - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [hcat (map ppr ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] - where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fv - -- It's OK to use nonDetUFMToList here because we only do it for - -- pretty printing - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv - --- nopDmdType is the demand of doing nothing --- (lazy, absent, no CPR information, no termination information). --- Note that it is ''not'' the top of the lattice (which would be "may use everything"), --- so it is (no longer) called topDmd -nopDmdType, botDmdType :: DmdType -nopDmdType = DmdType emptyDmdEnv [] topDiv -botDmdType = DmdType emptyDmdEnv [] botDiv - -isTopDmdType :: DmdType -> Bool -isTopDmdType (DmdType env [] res) - | isTopDiv res && isEmptyVarEnv env = True -isTopDmdType _ = False - -mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType -mkDmdType fv ds res = DmdType fv ds res - -dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds - --- | This makes sure we can use the demand type with n arguments. --- It extends the argument list with the correct resTypeArgDmd. --- It also adjusts the Divergence: Divergence survives additional arguments, --- CPR information does not (and definite converge also would not). -ensureArgs :: Arity -> DmdType -> DmdType -ensureArgs n d | n == depth = d - | otherwise = DmdType fv ds' r' - where depth = dmdTypeDepth d - DmdType fv ds r = d - - ds' = take n (ds ++ repeat (resTypeArgDmd r)) - r' = case r of -- See [Nature of result demand] - Dunno -> topDiv - _ -> r - - -seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () - -seqDmdEnv :: DmdEnv -> () -seqDmdEnv env = seqEltsUFM seqDemandList env - -splitDmdTy :: DmdType -> (Demand, DmdType) --- Split off one function argument --- We already have a suitable demand on all --- free vars, so no need to add more! -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) - --- When e is evaluated after executing an IO action, and d is e's demand, then --- what of this demand should we consider, given that the IO action can cleanly --- exit? --- * We have to kill all strictness demands (i.e. lub with a lazy demand) --- * We can keep usage information (i.e. lub with an absent demand) --- * We have to kill definite divergence --- * We can keep CPR information. --- See Note [IO hack in the demand analyser] in DmdAnal -deferAfterIO :: DmdType -> DmdType -deferAfterIO d@(DmdType _ _ res) = - case d `lubDmdType` nopDmdType of - DmdType fv ds _ -> DmdType fv ds (defer_res res) - where - defer_res r@(Dunno {}) = r - defer_res _ = topDiv -- Diverges - -strictenDmd :: Demand -> CleanDemand -strictenDmd (JD { sd = s, ud = u}) - = JD { sd = poke_s s, ud = poke_u u } - where - poke_s Lazy = HeadStr - poke_s (Str s) = s - poke_u Abs = UHead - poke_u (Use _ u) = u - --- Deferring and peeling - -type DmdShell -- Describes the "outer shell" - -- of a Demand - = JointDmd (Str ()) (Use ()) - -toCleanDmd :: Demand -> (DmdShell, CleanDemand) --- Splits a Demand into its "shell" and the inner "clean demand" -toCleanDmd (JD { sd = s, ud = u }) - = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) - -- See Note [Analyzing with lazy demand and lambdas] - -- See Note [Analysing with absent demand] - where - (ss, s') = case s of - Str s' -> (Str (), s') - Lazy -> (Lazy, HeadStr) - - (us, u') = case u of - Use c u' -> (Use c (), u') - Abs -> (Abs, Used) - --- This is used in dmdAnalStar when post-processing --- a function's argument demand. So we only care about what --- does to free variables, and whether it terminates. --- see Note [The need for BothDmdArg] -postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg -postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) - = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) - -postProcessDivergence :: Str () -> Divergence -> Divergence -postProcessDivergence Lazy _ = topDiv -postProcessDivergence _ res = res - -postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv -postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env - | Abs <- us = emptyDmdEnv - -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild - -- of the environment. Be careful, bad things will happen if this doesn't - -- match postProcessDmd (see #13977). - | Str _ <- ss - , Use One _ <- us = env - | otherwise = mapVarEnv (postProcessDmd ds) env - -- For the Absent case just discard all usage information - -- We only processed the thing at all to analyse the body - -- See Note [Always analyse in virgin pass] - -reuseEnv :: DmdEnv -> DmdEnv -reuseEnv = mapVarEnv (postProcessDmd - (JD { sd = Str (), ud = Use Many () })) - -postProcessUnsat :: DmdShell -> DmdType -> DmdType -postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) - = DmdType (postProcessDmdEnv ds fv) - (map (postProcessDmd ds) args) - (postProcessDivergence ss res_ty) - -postProcessDmd :: DmdShell -> Demand -> Demand -postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) - = JD { sd = s', ud = a' } - where - s' = case ss of - Lazy -> Lazy - Str _ -> s - a' = case us of - Abs -> Abs - Use Many _ -> markReusedDmd a - Use One _ -> a - --- Peels one call level from the demand, and also returns --- whether it was unsaturated (separately for strictness and usage) -peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) --- Exploiting the fact that --- on the strictness side C(B) = B --- and on the usage side C(U) = U -peelCallDmd (JD {sd = s, ud = u}) - = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) - where - (s', ss) = case s of - SCall s' -> (s', Str ()) - HyperStr -> (HyperStr, Str ()) - _ -> (HeadStr, Lazy) - (u', us) = case u of - UCall c u' -> (u', Use c ()) - _ -> (Used, Use Many ()) - -- The _ cases for usage includes UHead which seems a bit wrong - -- because the body isn't used at all! - -- c.f. the Abs case in toCleanDmd - --- Peels that multiple nestings of calls clean demand and also returns --- whether it was unsaturated (separately for strictness and usage --- see Note [Demands from unsaturated function calls] -peelManyCalls :: Int -> CleanDemand -> DmdShell -peelManyCalls n (JD { sd = str, ud = abs }) - = JD { sd = go_str n str, ud = go_abs n abs } - where - go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer - go_str 0 _ = Str () - go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) - go_str n (SCall d') = go_str (n-1) d' - go_str _ _ = Lazy - - go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least - go_abs 0 _ = Use One () -- one UCall Many in the demand - go_abs n (UCall One d') = go_abs (n-1) d' - go_abs _ _ = Use Many () - -{- -Note [Demands from unsaturated function calls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a demand transformer d1 -> d2 -> r for f. -If a sufficiently detailed demand is fed into this transformer, -e.g arising from "f x1 x2" in a strict, use-once context, -then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for -the free variable environment) and furthermore the result information r is the -one we want to use. - -An anonymous lambda is also an unsaturated function all (needs one argument, -none given), so this applies to that case as well. - -But the demand fed into f might be less than . There are a few cases: - * Not enough demand on the strictness side: - - In that case, we need to zap all strictness in the demand on arguments and - free variables. - - Furthermore, we remove CPR information. It could be left, but given the incoming - demand is not enough to evaluate so far we just do not bother. - - And finally termination information: If r says that f diverges for sure, - then this holds when the demand guarantees that two arguments are going to - be passed. If the demand is lower, we may just as well converge. - If we were tracking definite convegence, than that would still hold under - a weaker demand than expected by the demand transformer. - * Not enough demand from the usage side: The missing usage can be expanded - using UCall Many, therefore this is subsumed by the third case: - * At least one of the uses has a cardinality of Many. - - Even if f puts a One demand on any of its argument or free variables, if - we call f multiple times, we may evaluate this argument or free variable - multiple times. So forget about any occurrence of "One" in the demand. - -In dmdTransformSig, we call peelManyCalls to find out if we are in any of these -cases, and then call postProcessUnsat to reduce the demand appropriately. - -Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use -peelCallDmd, which peels only one level, but also returns the demand put on the -body of the function. --} - -peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds res, dmd) - where - fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables] - dmd = lookupVarEnv fv id `orElse` defaultDmd res - -addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res - -findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultDmd res - -{- -Note [Default demand on free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the variable is not mentioned in the environment of a demand type, -its demand is taken to be a result demand of the type. - For the strictness component, - if the result demand is a Diverges, then we use HyperStr - else we use Lazy - For the usage component, we use Absent. -So we use either absDmd or botDmd. - -Also note the equations for lubDivergence (resp. bothDivergence) noted there. - -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just returned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - -Note [Analyzing with lazy demand and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The insight for analyzing lambdas follows from the fact that for -strictness S = C(L). This polymorphic expansion is critical for -cardinality analysis of the following example: - -{-# NOINLINE build #-} -build g = (g (:) [], g (:) []) - -h c z = build (\x -> - let z1 = z ++ z - in if c - then \y -> x (y ++ z1) - else \y -> x (z1 ++ y)) - -One can see that `build` assigns to `g` demand . -Therefore, when analyzing the lambda `(\x -> ...)`, we -expect each lambda \y -> ... to be annotated as "one-shot" -one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a -demand . - -This is achieved by, first, converting the lazy demand L into the -strict S by the second clause of the analysis. - -Note [Analysing with absent demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we analyse an expression with demand . The "A" means -"absent", so this expression will never be needed. What should happen? -There are several wrinkles: - -* We *do* want to analyse the expression regardless. - Reason: Note [Always analyse in virgin pass] - - But we can post-process the results to ignore all the usage - demands coming back. This is done by postProcessDmdType. - -* In a previous incarnation of GHC we needed to be extra careful in the - case of an *unlifted type*, because unlifted values are evaluated - even if they are not used. Example (see #9254): - f :: (() -> (# Int#, () #)) -> () - -- Strictness signature is - -- - -- I.e. calls k, but discards first component of result - f k = case k () of (# _, r #) -> r - - g :: Int -> () - g y = f (\n -> (# case y of I# y2 -> y2, n #)) - - Here f's strictness signature says (correctly) that it calls its - argument function and ignores the first component of its result. - This is correct in the sense that it'd be fine to (say) modify the - function so that always returned 0# in the first component. - - But in function g, we *will* evaluate the 'case y of ...', because - it has type Int#. So 'y' will be evaluated. So we must record this - usage of 'y', else 'g' will say 'y' is absent, and will w/w so that - 'y' is bound to an aBSENT_ERROR thunk. - - However, the argument of toCleanDmd always satisfies the let/app - invariant; so if it is unlifted it is also okForSpeculation, and so - can be evaluated in a short finite time -- and that rules out nasty - cases like the one above. (I'm not quite sure why this was a - problem in an earlier version of GHC, but it isn't now.) - - -************************************************************************ -* * - Demand signatures -* * -************************************************************************ - -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping -a demand on the Id into a DmdType, which gives - a) the free vars of the Id's value - b) the Id's arguments - c) an indication of the result of applying - the Id to its arguments - -However, in fact we store in the Id an extremely emascuated demand -transfomer, namely - - a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) - -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. -Also see Note [Nature of result demand] for the meaning of a Divergence in a -strictness signature. - -If an Id is applied to less arguments than its arity, it means that -the demand on the function at a call site is weaker than the vanilla -call demand, used for signature inference. Therefore we place a top -demand on all arguments. Otherwise, the demand is specified by Id's -signature. - -For example, the demand transformer described by the demand signature - StrictSig (DmdType {x -> } m) -says that when the function is applied to two arguments, it -unleashes demand on the free var x, on the first arg, -and on the second, then returning a constructor. - -If this same function is applied to one arg, all we can say is that it -uses x with , and its arg with demand . - -Note [Understanding DmdType and StrictSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand types are sound approximations of an expression's semantics relative to -the incoming demand we put the expression under. Consider the following -expression: - - \x y -> x `seq` (y, 2*x) - -Here is a table with demand types resulting from different incoming demands we -put that expression under. Note the monotonicity; a stronger incoming demand -yields a more precise demand type: - - incoming demand | demand type - ---------------------------------------------------- - | {} - | {} - | {} - -Note that in the first example, the depth of the demand type was *higher* than -the arity of the incoming call demand due to the anonymous lambda. -The converse is also possible and happens when we unleash demand signatures. -In @f x y@, the incoming call demand on f has arity 2. But if all we have is a -demand signature with depth 1 for @f@ (which we can safely unleash, see below), -the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. - -So: Demand types are elicited by putting an expression under an incoming (call) -demand, the arity of which can be lower or higher than the depth of the -resulting demand type. -In contrast, a demand signature summarises a function's semantics *without* -immediately specifying the incoming demand it was produced under. Despite StrSig -being a newtype wrapper around DmdType, it actually encodes two things: - - * The threshold (i.e., minimum arity) to unleash the signature - * A demand type that is sound to unleash when the minimum arity requirement is - met. - -Here comes the subtle part: The threshold is encoded in the wrapped demand -type's depth! So in mkStrictSigForArity we make sure to trim the list of -argument demands to the given threshold arity. Call sites will make sure that -this corresponds to the arity of the call demand that elicited the wrapped -demand type. See also Note [What are demand signatures?] in DmdAnal. - -Besides trimming argument demands, mkStrictSigForArity will also trim CPR -information if necessary. --} - --- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe --- to unleash. Better construct this through 'mkStrictSigForArity'. --- See Note [Understanding DmdType and StrictSig] -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig :: StrictSig -> SDoc -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res - --- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] -mkStrictSigForArity :: Arity -> DmdType -> StrictSig -mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) - -mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig -mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) - -splitStrictSig :: StrictSig -> ([Demand], Divergence) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) - -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- ^ Add extra arguments to a strictness signature. --- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument --- demands and leaves CPR info intact. -increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) - | isTopDmdType dmd_ty = sig - | arity_increase == 0 = sig - | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" - <+> text "negative arity increase" - <+> ppr arity_increase ) - nopSig - | otherwise = StrictSig (DmdType env dmds' res) - where - dmds' = replicate arity_increase topDmd ++ dmds - -etaExpandStrictSig :: Arity -> StrictSig -> StrictSig --- ^ We are expanding (\x y. e) to (\x y z. e z). --- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if --- necessary, potentially destroying the signature's CPR property. -etaExpandStrictSig arity (StrictSig dmd_ty) - | arity < dmdTypeDepth dmd_ty - -- an arity decrease must zap the whole signature, because it was possibly - -- computed for a higher incoming call demand. - = nopSig - | otherwise - = StrictSig $ ensureArgs arity dmd_ty - -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -hasDemandEnvSig :: StrictSig -> Bool -hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) - -strictSigDmdEnv :: StrictSig -> DmdEnv -strictSigDmdEnv (StrictSig (DmdType env _ _)) = env - --- | True if the signature diverges or throws an exception -isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res - -nopSig, botSig :: StrictSig -nopSig = StrictSig nopDmdType -botSig = StrictSig botDmdType - -cprProdSig :: Arity -> StrictSig -cprProdSig _arity = nopSig - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - -dmdTransformSig :: StrictSig -> CleanDemand -> DmdType --- (dmdTransformSig fun_sig dmd) considers a call to a function whose --- signature is fun_sig, with demand dmd. We return the demand --- that the function places on its context (eg its args) -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd - = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty - -- see Note [Demands from unsaturated function calls] - -dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType --- Same as dmdTransformSig but for a data constructor (worker), --- which has a special kind of demand transformer. --- If the constructor is saturated, we feed the demand on --- the result into the constructor arguments. -dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) - (JD { sd = str, ud = abs }) - | Just str_dmds <- go_str arity str - , Just abs_dmds <- go_abs arity abs - = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res - -- Must remember whether it's a product, hence con_res, not TopRes - - | otherwise -- Not saturated - = nopDmdType - where - go_str 0 dmd = splitStrProdDmd arity dmd - go_str n (SCall s') = go_str (n-1) s' - go_str n HyperStr = go_str (n-1) HyperStr - go_str _ _ = Nothing - - go_abs 0 dmd = splitUseProdDmd arity dmd - go_abs n (UCall One u') = go_abs (n-1) u' - go_abs _ _ = Nothing - -dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType --- Like dmdTransformDataConSig, we have a special demand transformer --- for dictionary selectors. If the selector is saturated (ie has one --- argument: the dictionary), we feed the demand on the result into --- the indicated dictionary component. -dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd - | (cd',defer_use) <- peelCallDmd cd - , Just jds <- splitProdDmd_maybe dict_dmd - = postProcessUnsat defer_use $ - DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv - | otherwise - = nopDmdType -- See Note [Demand transformer for a dictionary selector] - where - enhance cd old | isAbsDmd old = old - | otherwise = mkOnceUsedDmd cd -- This is the one! - -dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" - -{- -Note [Demand transformer for a dictionary selector] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' -into the appropriate field of the dictionary. What *is* the appropriate field? -We just look at the strictness signature of the class op, which will be -something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. - -For single-method classes, which are represented by newtypes the signature -of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. -That's fine: if we are doing strictness analysis we are also doing inlining, -so we'll have inlined 'op' into a cast. So we can bale out in a conservative -way, returning nopDmdType. - -It is (just.. #8329) possible to be running strictness analysis *without* -having inlined class ops from single-method classes. Suppose you are using -ghc --make; and the first module has a local -O0 flag. So you may load a class -without interface pragmas, ie (currently) without an unfolding for the class -ops. Now if a subsequent module in the --make sweep has a local -O flag -you might do strictness analysis, but there is no inlining for the class op. -This is weird, so I'm not worried about whether this optimises brilliantly; but -it should not fall over. --} - -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] --- See Note [Computing one-shot info] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args - | unsaturated_call = [] - | otherwise = go arg_ds - where - unsaturated_call = arg_ds `lengthExceeds` n_val_args - - go [] = [] - go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds - - -- Avoid list tail like [ [], [], [] ] - cons [] [] = [] - cons a as = a:as - --- saturatedByOneShots n C1(C1(...)) = True, --- <=> --- there are at least n nested C1(..) calls --- See Note [Demand on the worker] in WorkWrap -saturatedByOneShots :: Int -> Demand -> Bool -saturatedByOneShots n (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go n arg_usg - _ -> False - where - go 0 _ = True - go n (UCall One u) = go (n-1) u - go _ _ = False - -argOneShots :: Demand -- depending on saturation - -> [OneShotInfo] -argOneShots (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go arg_usg - _ -> [] - where - go (UCall One u) = OneShotLam : go u - go (UCall Many u) = NoOneShotInfo : go u - go _ = [] - -{- Note [Computing one-shot info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a call - f (\pqr. e1) (\xyz. e2) e3 -where f has usage signature - C1(C(C1(U))) C1(U) U -Then argsOneShots returns a [[OneShotInfo]] of - [[OneShot,NoOneShotInfo,OneShot], [OneShot]] -The occurrence analyser propagates this one-shot infor to the -binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. --} - --- | Returns true if an application to n args --- would diverge or throw an exception --- See Note [Unsaturated applications] -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds res)) n - | isBotDiv res = not $ lengthExceeds ds n -appIsBottom _ _ = False - -{- -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a function having bottom as its demand result is applied to a less -number of arguments than its syntactic arity, we cannot say for sure -that it is going to diverge. This is the reason why we use the -function appIsBottom, which, given a strictness signature and a number -of arguments, says conservatively if the function is going to diverge -or not. - -Zap absence or one-shot information, under control of flags - -Note [Killing usage information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flags -fkill-one-shot and -fkill-absence let you switch off the generation -of absence or one-shot information altogether. This is only used for performance -tests, to see how important they are. --} - -zapUsageEnvSig :: StrictSig -> StrictSig --- Remove the usage environment from the demand -zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r - -zapUsageDemand :: Demand -> Demand --- Remove the usage info, but not the strictness info, from the demand -zapUsageDemand = kill_usage $ KillFlags - { kf_abs = True - , kf_used_once = True - , kf_called_once = True - } - --- | Remove all 1* information (but not C1 information) from the demand -zapUsedOnceDemand :: Demand -> Demand -zapUsedOnceDemand = kill_usage $ KillFlags - { kf_abs = False - , kf_used_once = True - , kf_called_once = False - } - --- | Remove all 1* information (but not C1 information) from the strictness --- signature -zapUsedOnceSig :: StrictSig -> StrictSig -zapUsedOnceSig (StrictSig (DmdType env ds r)) - = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) - -killUsageDemand :: DynFlags -> Demand -> Demand --- See Note [Killing usage information] -killUsageDemand dflags dmd - | Just kfs <- killFlags dflags = kill_usage kfs dmd - | otherwise = dmd - -killUsageSig :: DynFlags -> StrictSig -> StrictSig --- See Note [Killing usage information] -killUsageSig dflags sig@(StrictSig (DmdType env ds r)) - | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) - | otherwise = sig - -data KillFlags = KillFlags - { kf_abs :: Bool - , kf_used_once :: Bool - , kf_called_once :: Bool - } - -killFlags :: DynFlags -> Maybe KillFlags --- See Note [Killing usage information] -killFlags dflags - | not kf_abs && not kf_used_once = Nothing - | otherwise = Just (KillFlags {..}) - where - kf_abs = gopt Opt_KillAbsence dflags - kf_used_once = gopt Opt_KillOneShot dflags - kf_called_once = kf_used_once - -kill_usage :: KillFlags -> Demand -> Demand -kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} - -zap_musg :: KillFlags -> ArgUse -> ArgUse -zap_musg kfs Abs - | kf_abs kfs = useTop - | otherwise = Abs -zap_musg kfs (Use c u) - | kf_used_once kfs = Use Many (zap_usg kfs u) - | otherwise = Use c (zap_usg kfs u) - -zap_usg :: KillFlags -> UseDmd -> UseDmd -zap_usg kfs (UCall c u) - | kf_called_once kfs = UCall Many (zap_usg kfs u) - | otherwise = UCall c (zap_usg kfs u) -zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) -zap_usg _ u = u - --- If the argument is a used non-newtype dictionary, give it strict --- demand. Also split the product type & demand and recur in order to --- similarly strictify the argument's contained used non-newtype --- superclass dictionaries. We use the demand as our recursive measure --- to guarantee termination. -strictifyDictDmd :: Type -> Demand -> Demand -strictifyDictDmd ty dmd = case getUseDmd dmd of - Use n _ | - Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) - <- splitDataProductType_maybe ty, - not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary - -> seqDmd `bothDmd` -- main idea: ensure it's strict - case splitProdDmd_maybe dmd of - -- superclass cycles should not be a problem, since the demand we are - -- consuming would also have to be infinite in order for us to diverge - Nothing -> dmd -- no components have interesting demand, so stop - -- looking for superclass dicts - Just dmds - | all (not . isAbsDmd) dmds -> evalDmd - -- abstract to strict w/ arbitrary component use, since this - -- smells like reboxing; results in CBV boxed - -- - -- TODO revisit this if we ever do boxity analysis - | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of - JD {sd = s,ud = a} -> JD (Str s) (Use n a) - -- TODO could optimize with an aborting variant of zipWith since - -- the superclass dicts are always a prefix - _ -> dmd -- unused or not a dictionary - -strictifyDmd :: Demand -> Demand -strictifyDmd dmd@(JD { sd = str }) - = dmd { sd = str `bothArgStr` Str HeadStr } - -{- -Note [HyperStr and Use demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The information "HyperStr" needs to be in the strictness signature, and not in -the demand signature, because we still want to know about the demand on things. Consider - - f (x,y) True = error (show x) - f (x,y) False = x+1 - -The signature of f should be m. If we were not -distinguishing the uses on x and y in the True case, we could either not figure -out how deeply we can unpack x, or that we do not have to pass y. - - -************************************************************************ -* * - Serialisation -* * -************************************************************************ --} - -instance Binary StrDmd where - put_ bh HyperStr = do putByte bh 0 - put_ bh HeadStr = do putByte bh 1 - put_ bh (SCall s) = do putByte bh 2 - put_ bh s - put_ bh (SProd sx) = do putByte bh 3 - put_ bh sx - get bh = do - h <- getByte bh - case h of - 0 -> do return HyperStr - 1 -> do return HeadStr - 2 -> do s <- get bh - return (SCall s) - _ -> do sx <- get bh - return (SProd sx) - -instance Binary ArgStr where - put_ bh Lazy = do - putByte bh 0 - put_ bh (Str s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return Lazy - _ -> do s <- get bh - return $ Str s - -instance Binary Count where - put_ bh One = do putByte bh 0 - put_ bh Many = do putByte bh 1 - - get bh = do h <- getByte bh - case h of - 0 -> return One - _ -> return Many - -instance Binary ArgUse where - put_ bh Abs = do - putByte bh 0 - put_ bh (Use c u) = do - putByte bh 1 - put_ bh c - put_ bh u - - get bh = do - h <- getByte bh - case h of - 0 -> return Abs - _ -> do c <- get bh - u <- get bh - return $ Use c u - -instance Binary UseDmd where - put_ bh Used = do - putByte bh 0 - put_ bh UHead = do - putByte bh 1 - put_ bh (UCall c u) = do - putByte bh 2 - put_ bh c - put_ bh u - put_ bh (UProd ux) = do - putByte bh 3 - put_ bh ux - - get bh = do - h <- getByte bh - case h of - 0 -> return $ Used - 1 -> return $ UHead - 2 -> do c <- get bh - u <- get bh - return (UCall c u) - _ -> do ux <- get bh - return (UProd ux) - -instance (Binary s, Binary u) => Binary (JointDmd s u) where - put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = do - x <- get bh - y <- get bh - return $ JD { sd = x, ud = y } - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance Binary DmdType where - -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) - = do put_ bh ds - put_ bh dr - get bh - = do ds <- get bh - dr <- get bh - return (DmdType emptyDmdEnv ds dr) - -instance Binary Divergence where - put_ bh Dunno = putByte bh 0 - put_ bh Diverges = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return Dunno - _ -> return Diverges } diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs deleted file mode 100644 --- a/compiler/basicTypes/FieldLabel.hs +++ /dev/null @@ -1,130 +0,0 @@ -{- -% -% (c) Adam Gundry 2013-2015 -% - -This module defines the representation of FieldLabels as stored in -TyCons. As well as a selector name, these have some extra structure -to support the DuplicateRecordFields extension. - -In the normal case (with NoDuplicateRecordFields), a datatype like - - data T = MkT { foo :: Int } - -has - - FieldLabel { flLabel = "foo" - , flIsOverloaded = False - , flSelector = foo }. - -In particular, the Name of the selector has the same string -representation as the label. If DuplicateRecordFields -is enabled, however, the same declaration instead gives - - FieldLabel { flLabel = "foo" - , flIsOverloaded = True - , flSelector = $sel:foo:MkT }. - -Now the name of the selector ($sel:foo:MkT) does not match the label of -the field (foo). We must be careful not to show the selector name to -the user! The point of mangling the selector name is to allow a -module to define the same field label in different datatypes: - - data T = MkT { foo :: Int } - data U = MkU { foo :: Bool } - -Now there will be two FieldLabel values for 'foo', one in T and one in -U. They share the same label (FieldLabelString), but the selector -functions differ. - -See also Note [Representing fields in AvailInfo] in Avail. - -Note [Why selector names include data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As explained above, a selector name includes the name of the first -data constructor in the type, so that the same label can appear -multiple times in the same module. (This is irrespective of whether -the first constructor has that field, for simplicity.) - -We use a data constructor name, rather than the type constructor name, -because data family instances do not have a representation type -constructor name generated until relatively late in the typechecking -process. - -Of course, datatypes with no constructors cannot have any fields. - --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} - -module FieldLabel ( FieldLabelString - , FieldLabelEnv - , FieldLbl(..) - , FieldLabel - , mkFieldLabelOccs - ) where - -import GhcPrelude - -import OccName -import Name - -import FastString -import FastStringEnv -import Outputable -import Binary - -import Data.Data - --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - --- | A map from labels to all the auxiliary information -type FieldLabelEnv = DFastStringEnv FieldLabel - - -type FieldLabel = FieldLbl Name - --- | Fields in an algebraic record type -data FieldLbl a = FieldLabel { - flLabel :: FieldLabelString, -- ^ User-visible label of the field - flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on - -- in the defining module for this datatype? - flSelector :: a -- ^ Record selector function - } - deriving (Eq, Functor, Foldable, Traversable) -deriving instance Data a => Data (FieldLbl a) - -instance Outputable a => Outputable (FieldLbl a) where - ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) - -instance Binary a => Binary (FieldLbl a) where - put_ bh (FieldLabel aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - ad <- get bh - return (FieldLabel ab ac ad) - - --- | Record selector OccNames are built from the underlying field name --- and the name of the first data constructor of the type, to support --- duplicate record field names. --- See Note [Why selector names include data constructors]. -mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName -mkFieldLabelOccs lbl dc is_overloaded - = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = sel_occ } - where - str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc - sel_occ | is_overloaded = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs deleted file mode 100644 --- a/compiler/basicTypes/Id.hs +++ /dev/null @@ -1,970 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Id]{@Ids@: Value and constructor identifiers} --} - -{-# LANGUAGE CPP #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional --- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that --- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either --- be global or local, see "Var#globalvslocal" --- --- * 'Var.Var': see "Var#name_types" - -module Id ( - -- * The main types - Var, Id, isId, - - -- * In and Out variants - InVar, InId, - OutVar, OutId, - - -- ** Simple construction - mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, - mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, - mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, - mkUserLocal, mkUserLocalOrCoVar, - mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, - - -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - recordSelectorTyCon, - - -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, - setIdExported, setIdNotExported, - globaliseId, localiseId, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, - zapIdUsedOnceInfo, zapIdTailCallInfo, - zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, - transferPolyIdInfo, - - -- ** Predicates on Ids - isImplicitId, isDeadBinder, - isStrictId, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, isNaughtyRecordSelector, - isPatSynRecordSelector, - isDataConRecordSelector, - isClassOpId_maybe, isDFunId, - isPrimOpId, isPrimOpId_maybe, - isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, - isDataConWrapId, isDataConWrapId_maybe, - isDataConId_maybe, - idDataCon, - isConLikeId, isBottomingId, idIsFrom, - hasNoBinding, - - -- ** Join variables - JoinId, isJoinId, isJoinId_maybe, idJoinArity, - asJoinId, asJoinId_maybe, zapJoinId, - - -- ** Inline pragma stuff - idInlinePragma, setInlinePragma, modifyInlinePragma, - idInlineActivation, setInlineActivation, idRuleMatchInfo, - - -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, - setOneShotLambda, clearOneShotLambda, - updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, - - -- ** Reading 'IdInfo' fields - idArity, - idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, - idSpecialisation, idCoreRules, idHasRules, - idCafInfo, - idOneShotInfo, idStateHackOneShotInfo, - idOccInfo, - isNeverLevPolyId, - - -- ** Writing 'IdInfo' fields - setIdUnfolding, setCaseBndrEvald, - setIdArity, - setIdCallArity, - - setIdSpecialisation, - setIdCafInfo, - setIdOccInfo, zapIdOccInfo, - - setIdDemandInfo, - setIdStrictness, - setIdCprInfo, - - idDemandInfo, - idStrictness, - idCprInfo, - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) - -import IdInfo -import BasicTypes - --- Imported and re-exported -import Var( Id, CoVar, JoinId, - InId, InVar, - OutId, OutVar, - idInfo, idDetails, setIdDetails, globaliseId, varType, - isId, isLocalId, isGlobalId, isExportedId ) -import qualified Var - -import Type -import GHC.Types.RepType -import TysPrim -import DataCon -import Demand -import Cpr -import Name -import Module -import Class -import {-# SOURCE #-} PrimOp (PrimOp) -import ForeignCall -import Maybes -import SrcLoc -import Outputable -import Unique -import UniqSupply -import FastString -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfolding`, - `setIdArity`, - `setIdCallArity`, - `setIdOccInfo`, - `setIdOneShotInfo`, - - `setIdSpecialisation`, - `setInlinePragma`, - `setInlineActivation`, - `idCafInfo`, - - `setIdDemandInfo`, - `setIdStrictness`, - `setIdCprInfo`, - - `asJoinId`, - `asJoinId_maybe` - -{- -************************************************************************ -* * -\subsection{Basic Id manipulation} -* * -************************************************************************ --} - -idName :: Id -> Name -idName = Var.varName - -idUnique :: Id -> Unique -idUnique = Var.varUnique - -idType :: Id -> Kind -idType = Var.varType - -setIdName :: Id -> Name -> Id -setIdName = Var.setVarName - -setIdUnique :: Id -> Unique -> Id -setIdUnique = Var.setVarUnique - --- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and --- reduce space usage -setIdType :: Id -> Type -> Id -setIdType id ty = seqType ty `seq` Var.setVarType id ty - -setIdExported :: Id -> Id -setIdExported = Var.setIdExported - -setIdNotExported :: Id -> Id -setIdNotExported = Var.setIdNotExported - -localiseId :: Id -> Id --- Make an Id with the same unique and type as the --- incoming Id, but with an *Internal* Name and *LocalId* flavour -localiseId id - | ASSERT( isId id ) isLocalId id && isInternalName name - = id - | otherwise - = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) - where - name = idName id - -lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = Var.lazySetIdInfo - -setIdInfo :: Id -> IdInfo -> Id -setIdInfo id info = info `seq` (lazySetIdInfo id info) - -- Try to avoid space leaks by seq'ing - -modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) - --- maybeModifyIdInfo tries to avoid unnecessary thrashing -maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id -maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info -maybeModifyIdInfo Nothing id = id - -{- -************************************************************************ -* * -\subsection{Simple Id construction} -* * -************************************************************************ - -Absolutely all Ids are made by mkId. It is just like Var.mkId, -but in addition it pins free-tyvar-info onto the Id's type, -where it can easily be found. - -Note [Free type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we cached the free type variables of the type of an Id -at the root of the type in a TyNote. The idea was to avoid repeating -the free-type-variable calculation. But it turned out to slow down -the compiler overall. I don't quite know why; perhaps finding free -type variables of an Id isn't all that common whereas applying a -substitution (which changes the free type variables) is more common. -Anyway, we removed it in March 2008. --} - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId = Var.mkGlobalVar - --- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id -mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo - --- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkLocalId :: HasDebugCallStack => Name -> Type -> Id -mkLocalId name ty = ASSERT( not (isCoVarType ty) ) - mkLocalIdWithInfo name ty vanillaIdInfo - --- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar -mkLocalCoVar name ty - = ASSERT( isCoVarType ty ) - Var.mkLocalVar CoVarId name ty vanillaIdInfo - --- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Type -> Id -mkLocalIdOrCoVar name ty - | isCoVarType ty = mkLocalCoVar name ty - | otherwise = mkLocalId name ty - - -- proper ids only; no covars! -mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) ) - Var.mkLocalVar VanillaId name ty info - -- Note [Free type variables] - --- | Create a local 'Id' that is marked as exported. --- This prevents things attached to it from being removed as dead code. --- See Note [Exported LocalIds] -mkExportedLocalId :: IdDetails -> Name -> Type -> Id -mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo - -- Note [Free type variables] - -mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo - -- Note [Free type variables] - - --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") --- that are created by the compiler out of thin air -mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkSystemVarName uniq fs) ty - --- | Like 'mkSysLocal', but checks to see if we have a covar type -mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id -mkSysLocalOrCoVar fs uniq ty - = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty - -mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) - -mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalOrCoVarM fs ty - = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) - --- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize -mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkInternalName uniq occ loc) ty - --- | Like 'mkUserLocal', but checks if we have a coercion type -mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocalOrCoVar occ uniq ty loc - = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty - -{- -Make some local @Ids@ for a template @CoreExpr@. These have bogus -@Uniques@, but that's OK because the templates are supposed to be -instantiated before use. --} - --- | Workers get local names. "CoreTidy" will externalise these if necessary -mkWorkerId :: Unique -> Id -> Type -> Id -mkWorkerId uniq unwrkr ty - = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty - --- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings -mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty - -- "OrCoVar" since this is used in a superclass selector, - -- and "~" and "~~" have coercion "superclasses". - --- | Create a template local for a series of types -mkTemplateLocals :: [Type] -> [Id] -mkTemplateLocals = mkTemplateLocalsNum 1 - --- | Create a template local for a series of type, but start from a specified template local -mkTemplateLocalsNum :: Int -> [Type] -> [Id] -mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys - -{- Note [Exported LocalIds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use mkExportedLocalId for things like - - Dictionary functions (DFunId) - - Wrapper and matcher Ids for pattern synonyms - - Default methods for classes - - Pattern-synonym matcher and builder Ids - - etc - -They marked as "exported" in the sense that they should be kept alive -even if apparently unused in other bindings, and not dropped as dead -code by the occurrence analyser. (But "exported" here does not mean -"brought into lexical scope by an import declaration". Indeed these -things are always internal Ids that the user never sees.) - -It's very important that they are *LocalIds*, not GlobalIds, for lots -of reasons: - - * We want to treat them as free variables for the purpose of - dependency analysis (e.g. GHC.Core.FVs.exprFreeVars). - - * Look them up in the current substitution when we come across - occurrences of them (in Subst.lookupIdSubst). Lacking this we - can get an out-of-date unfolding, which can in turn make the - simplifier go into an infinite loop (#9857) - - * Ensure that for dfuns that the specialiser does not float dict uses - above their defns, which would prevent good simplifications happening. - - * The strictness analyser treats a occurrence of a GlobalId as - imported and assumes it contains strictness in its IdInfo, which - isn't true if the thing is bound in the same module as the - occurrence. - -In CoreTidy we must make all these LocalIds into GlobalIds, so that in -importing modules (in --make mode) we treat them as properly global. -That is what is happening in, say tidy_insts in GHC.Iface.Tidy. - -************************************************************************ -* * -\subsection{Special Ids} -* * -************************************************************************ --} - --- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. -recordSelectorTyCon :: Id -> RecSelParent -recordSelectorTyCon id - = case Var.idDetails id of - RecSelId { sel_tycon = parent } -> parent - _ -> panic "recordSelectorTyCon" - - -isRecordSelector :: Id -> Bool -isNaughtyRecordSelector :: Id -> Bool -isPatSynRecordSelector :: Id -> Bool -isDataConRecordSelector :: Id -> Bool -isPrimOpId :: Id -> Bool -isFCallId :: Id -> Bool -isDataConWorkId :: Id -> Bool -isDataConWrapId :: Id -> Bool -isDFunId :: Id -> Bool - -isClassOpId_maybe :: Id -> Maybe Class -isPrimOpId_maybe :: Id -> Maybe PrimOp -isFCallId_maybe :: Id -> Maybe ForeignCall -isDataConWorkId_maybe :: Id -> Maybe DataCon -isDataConWrapId_maybe :: Id -> Maybe DataCon - -isRecordSelector id = case Var.idDetails id of - RecSelId {} -> True - _ -> False - -isDataConRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelData _} -> True - _ -> False - -isPatSynRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelPatSyn _} -> True - _ -> False - -isNaughtyRecordSelector id = case Var.idDetails id of - RecSelId { sel_naughty = n } -> n - _ -> False - -isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing - -isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False - -isDFunId id = case Var.idDetails id of - DFunId {} -> True - _ -> False - -isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing - -isFCallId id = case Var.idDetails id of - FCallId _ -> True - _ -> False - -isFCallId_maybe id = case Var.idDetails id of - FCallId call -> Just call - _ -> Nothing - -isDataConWorkId id = case Var.idDetails id of - DataConWorkId _ -> True - _ -> False - -isDataConWorkId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - _ -> Nothing - -isDataConWrapId id = case Var.idDetails id of - DataConWrapId _ -> True - _ -> False - -isDataConWrapId_maybe id = case Var.idDetails id of - DataConWrapId con -> Just con - _ -> Nothing - -isDataConId_maybe :: Id -> Maybe DataCon -isDataConId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - DataConWrapId con -> Just con - _ -> Nothing - -isJoinId :: Var -> Bool --- It is convenient in SetLevels.lvlMFE to apply isJoinId --- to the free vars of an expression, so it's convenient --- if it returns False for type variables -isJoinId id - | isId id = case Var.idDetails id of - JoinId {} -> True - _ -> False - | otherwise = False - -isJoinId_maybe :: Var -> Maybe JoinArity -isJoinId_maybe id - | isId id = ASSERT2( isId id, ppr id ) - case Var.idDetails id of - JoinId arity -> Just arity - _ -> Nothing - | otherwise = Nothing - -idDataCon :: Id -> DataCon --- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. --- --- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker -idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -hasNoBinding :: Id -> Bool --- ^ Returns @True@ of an 'Id' which may not have a --- binding, even though it is defined in this module. - --- Data constructor workers used to be things of this kind, but --- they aren't any more. Instead, we inject a binding for --- them at the CorePrep stage. --- --- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. --- for the history of this. --- --- Note that CorePrep currently eta expands things no-binding things and this --- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things --- in CorePrep] in CorePrep for details. --- --- EXCEPT: unboxed tuples, which definitely have no binding -hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs - FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc - _ -> isCompulsoryUnfolding (idUnfolding id) - -- See Note [Levity-polymorphic Ids] - -isImplicitId :: Id -> Bool --- ^ 'isImplicitId' tells whether an 'Id's info is implied by other --- declarations, so we don't need to put its signature in an interface --- file, even if it's mentioned in some other interface unfolding. -isImplicitId id - = case Var.idDetails id of - FCallId {} -> True - ClassOpId {} -> True - PrimOpId {} -> True - DataConWorkId {} -> True - DataConWrapId {} -> True - -- These are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id is not an implicit Id; it must *not* be omitted, because - -- it carries version info for the instance decl - _ -> False - -idIsFrom :: Module -> Id -> Bool -idIsFrom mod id = nameIsLocalOrFrom mod (idName id) - -{- Note [Levity-polymorphic Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some levity-polymorphic Ids must be applied and inlined, not left -un-saturated. Example: - unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b - -This has a compulsory unfolding because we can't lambda-bind those -arguments. But the compulsory unfolding may leave levity-polymorphic -lambdas if it is not applied to enough arguments; e.g. (#14561) - bad :: forall (a :: TYPE r). a -> a - bad = unsafeCoerce# - -The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop. -And we want that magic to apply to levity-polymorphic compulsory-inline things. -The easiest way to do this is for hasNoBinding to return True of all things -that have compulsory unfolding. Some Ids with a compulsory unfolding also -have a binding, but it does not harm to say they don't here, and its a very -simple way to fix #14561. --} - -isDeadBinder :: Id -> Bool -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead - -{- -************************************************************************ -* * - Join variables -* * -************************************************************************ --} - -idJoinArity :: JoinId -> JoinArity -idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) - -asJoinId :: Id -> JoinArity -> JoinId -asJoinId id arity = WARN(not (isLocalId id), - text "global id being marked as join var:" <+> ppr id) - WARN(not (is_vanilla_or_join id), - ppr id <+> pprIdDetails (idDetails id)) - id `setIdDetails` JoinId arity - where - is_vanilla_or_join id = case Var.idDetails id of - VanillaId -> True - JoinId {} -> True - _ -> False - -zapJoinId :: Id -> Id --- May be a regular id already -zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) - -- Core Lint may complain if still marked - -- as AlwaysTailCalled - | otherwise = jid - -asJoinId_maybe :: Id -> Maybe JoinArity -> Id -asJoinId_maybe id (Just arity) = asJoinId id arity -asJoinId_maybe id Nothing = zapJoinId id - -{- -************************************************************************ -* * -\subsection{IdInfo stuff} -* * -************************************************************************ --} - - --------------------------------- - -- ARITY -idArity :: Id -> Arity -idArity id = arityInfo (idInfo id) - -setIdArity :: Id -> Arity -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id - -idCallArity :: Id -> Arity -idCallArity id = callArityInfo (idInfo id) - -setIdCallArity :: Id -> Arity -> Id -setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id - -idFunRepArity :: Id -> RepArity -idFunRepArity x = countFunRepArgs (idArity x) (idType x) - --- | Returns true if an application to n args would diverge -isBottomingId :: Var -> Bool -isBottomingId v - | isId v = isBottomingSig (idStrictness v) - | otherwise = False - --- | Accesses the 'Id''s 'strictnessInfo'. -idStrictness :: Id -> StrictSig -idStrictness id = strictnessInfo (idInfo id) - -setIdStrictness :: Id -> StrictSig -> Id -setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id - -idCprInfo :: Id -> CprSig -idCprInfo id = cprInfo (idInfo id) - -setIdCprInfo :: Id -> CprSig -> Id -setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id - -zapIdStrictness :: Id -> Id -zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id - --- | This predicate says whether the 'Id' has a strict demand placed on it or --- has a type such that it can always be evaluated strictly (i.e an --- unlifted type, as of GHC 7.6). We need to --- check separately whether the 'Id' has a so-called \"strict type\" because if --- the demand for the given @id@ hasn't been computed yet but @id@ has a strict --- type, we still want @isStrictId id@ to be @True@. -isStrictId :: Id -> Bool -isStrictId id - = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - not (isJoinId id) && ( - (isStrictType (idType id)) || - -- Take the best of both strictnesses - old and new - (isStrictDmd (idDemandInfo id)) - ) - - --------------------------------- - -- UNFOLDING -idUnfolding :: Id -> Unfolding --- Do not expose the unfolding of a loop breaker! -idUnfolding id - | isStrongLoopBreaker (occInfo info) = NoUnfolding - | otherwise = unfoldingInfo info - where - info = idInfo id - -realIdUnfolding :: Id -> Unfolding --- Expose the unfolding if there is one, including for loop breakers -realIdUnfolding id = unfoldingInfo (idInfo id) - -setIdUnfolding :: Id -> Unfolding -> Id -setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id - -idDemandInfo :: Id -> Demand -idDemandInfo id = demandInfo (idInfo id) - -setIdDemandInfo :: Id -> Demand -> Id -setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id - -setCaseBndrEvald :: StrictnessMark -> Id -> Id --- Used for variables bound by a case expressions, both the case-binder --- itself, and any pattern-bound variables that are argument of a --- strict constructor. It just marks the variable as already-evaluated, --- so that (for example) a subsequent 'seq' can be dropped -setCaseBndrEvald str id - | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding - | otherwise = id - - --------------------------------- - -- SPECIALISATION - --- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs - -idSpecialisation :: Id -> RuleInfo -idSpecialisation id = ruleInfo (idInfo id) - -idCoreRules :: Id -> [CoreRule] -idCoreRules id = ruleInfoRules (idSpecialisation id) - -idHasRules :: Id -> Bool -idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) - -setIdSpecialisation :: Id -> RuleInfo -> Id -setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id - - --------------------------------- - -- CAF INFO -idCafInfo :: Id -> CafInfo -idCafInfo id = cafInfo (idInfo id) - -setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id - - --------------------------------- - -- Occurrence INFO -idOccInfo :: Id -> OccInfo -idOccInfo id = occInfo (idInfo id) - -setIdOccInfo :: Id -> OccInfo -> Id -setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id - -zapIdOccInfo :: Id -> Id -zapIdOccInfo b = b `setIdOccInfo` noOccInfo - -{- - --------------------------------- - -- INLINING -The inline pragma tells us to be very keen to inline this Id, but it's still -OK not to if optimisation is switched off. --} - -idInlinePragma :: Id -> InlinePragma -idInlinePragma id = inlinePragInfo (idInfo id) - -setInlinePragma :: Id -> InlinePragma -> Id -setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id - -modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id -modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id - -idInlineActivation :: Id -> Activation -idInlineActivation id = inlinePragmaActivation (idInlinePragma id) - -setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) - -idRuleMatchInfo :: Id -> RuleMatchInfo -idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) - -isConLikeId :: Id -> Bool -isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) - -{- - --------------------------------- - -- ONE-SHOT LAMBDAS --} - -idOneShotInfo :: Id -> OneShotInfo -idOneShotInfo id = oneShotInfo (idInfo id) - --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in GHC.Core.Arity -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in GHC.Core.Arity -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | hasNoStateHack unsafeGlobalDynFlags - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - -setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id - -clearOneShotLambda :: Id -> Id -clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id - -setIdOneShotInfo :: Id -> OneShotInfo -> Id -setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id - -updOneShotInfo :: Id -> OneShotInfo -> Id --- Combine the info in the Id with new info -updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False - --- The OneShotLambda functions simply fiddle with the IdInfo flag --- But watch out: this may change the type of something else --- f = \x -> e --- If we change the one-shot-ness of x, f's type changes - -zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id -zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id - -zapLamIdInfo :: Id -> Id -zapLamIdInfo = zapInfo zapLamInfo - -zapFragileIdInfo :: Id -> Id -zapFragileIdInfo = zapInfo zapFragileInfo - -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo - -zapIdUsageInfo :: Id -> Id -zapIdUsageInfo = zapInfo zapUsageInfo - -zapIdUsageEnvInfo :: Id -> Id -zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo - -zapIdUsedOnceInfo :: Id -> Id -zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo - -zapIdTailCallInfo :: Id -> Id -zapIdTailCallInfo = zapInfo zapTailCallInfo - -zapStableUnfolding :: Id -> Id -zapStableUnfolding id - | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding - | otherwise = id - -{- -Note [transferPolyIdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This transfer is used in three places: - FloatOut (long-distance let-floating) - SimplUtils.abstractFloats (short-distance let-floating) - StgLiftLams (selectively lambda-lift local functions to top-level) - -Consider the short-distance let-floating: - - f = /\a. let g = rhs in ... - -Then if we float thus - - g' = /\a. rhs - f = /\a. ...[g' a/g].... - -we *do not* want to lose g's - * strictness information - * arity - * inline pragma (though that is bit more debatable) - * occurrence info - -Mostly this is just an optimisation, but it's *vital* to -transfer the occurrence info. Consider - - NonRec { f = /\a. let Rec { g* = ..g.. } in ... } - -where the '*' means 'LoopBreaker'. Then if we float we must get - - Rec { g'* = /\a. ...(g' a)... } - NonRec { f = /\a. ...[g' a/g]....} - -where g' is also marked as LoopBreaker. If not, terrible things -can happen if we re-simplify the binding (and the Simplifier does -sometimes simplify a term twice); see #4345. - -It's not so simple to retain - * worker info - * rules -so we simply discard those. Sooner or later this may bite us. - -If we abstract wrt one or more *value* binders, we must modify the -arity and strictness info before transferring it. E.g. - f = \x. e ---> - g' = \y. \x. e - + substitute (g' y) for g -Notice that g' has an arity one more than the original g --} - -transferPolyIdInfo :: Id -- Original Id - -> [Var] -- Abstract wrt these variables - -> Id -- New Id - -> Id -transferPolyIdInfo old_id abstract_wrt new_id - = modifyIdInfo transfer new_id - where - arity_increase = count isId abstract_wrt -- Arity increases by the - -- number of value binders - - old_info = idInfo old_id - old_arity = arityInfo old_info - old_inline_prag = inlinePragInfo old_info - old_occ_info = occInfo old_info - new_arity = old_arity + arity_increase - new_occ_info = zapOccTailCallInfo old_occ_info - - old_strictness = strictnessInfo old_info - new_strictness = increaseStrictSigArity arity_increase old_strictness - old_cpr = cprInfo old_info - - transfer new_info = new_info `setArityInfo` new_arity - `setInlinePragInfo` old_inline_prag - `setOccInfo` new_occ_info - `setStrictnessInfo` new_strictness - `setCprInfo` old_cpr - -isNeverLevPolyId :: Id -> Bool -isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs deleted file mode 100644 --- a/compiler/basicTypes/IdInfo.hs +++ /dev/null @@ -1,652 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} - -(And a pretty good illustration of quite a few things wrong with -Haskell. [WDP 94/11]) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module IdInfo ( - -- * The IdDetails type - IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, - JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), - - -- * The IdInfo type - IdInfo, -- Abstract - vanillaIdInfo, noCafIdInfo, - - -- ** The OneShotInfo type - OneShotInfo(..), - oneShotInfo, noOneShotInfo, hasNoOneShotInfo, - setOneShotInfo, - - -- ** Zapping various forms of Info - zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, - zapTailCallInfo, zapCallArityInfo, zapUnfolding, - - -- ** The ArityInfo type - ArityInfo, - unknownArity, - arityInfo, setArityInfo, ppArityInfo, - - callArityInfo, setCallArityInfo, - - -- ** Demand and strictness Info - strictnessInfo, setStrictnessInfo, - cprInfo, setCprInfo, - demandInfo, setDemandInfo, pprStrictness, - - -- ** Unfolding Info - unfoldingInfo, setUnfoldingInfo, - - -- ** The InlinePragInfo type - InlinePragInfo, - inlinePragInfo, setInlinePragInfo, - - -- ** The OccInfo type - OccInfo(..), - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, - occInfo, setOccInfo, - - InsideLam(..), OneBranch(..), - - TailCallInfo(..), - tailCallInfo, isAlwaysTailCalled, - - -- ** The RuleInfo type - RuleInfo(..), - emptyRuleInfo, - isEmptyRuleInfo, ruleInfoFreeVars, - ruleInfoRules, setRuleInfoHead, - ruleInfo, setRuleInfo, - - -- ** The CAFInfo type - CafInfo(..), - ppCafInfo, mayHaveCafRefs, - cafInfo, setCafInfo, - - -- ** Tick-box Info - TickBoxOp(..), TickBoxId, - - -- ** Levity info - LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, - isNeverLevPolyIdInfo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core - -import Class -import {-# SOURCE #-} PrimOp (PrimOp) -import Name -import VarSet -import BasicTypes -import DataCon -import TyCon -import PatSyn -import Type -import ForeignCall -import Outputable -import Module -import Demand -import Cpr -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setRuleInfo`, - `setArityInfo`, - `setInlinePragInfo`, - `setUnfoldingInfo`, - `setOneShotInfo`, - `setOccInfo`, - `setCafInfo`, - `setStrictnessInfo`, - `setCprInfo`, - `setDemandInfo`, - `setNeverLevPoly`, - `setLevityInfoWithType` - -{- -************************************************************************ -* * - IdDetails -* * -************************************************************************ --} - --- | Identifier Details --- --- The 'IdDetails' of an 'Id' give stable, and necessary, --- information about the Id. -data IdDetails - = VanillaId - - -- | The 'Id' for a record selector - | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: - -- data T = forall a. MkT { x :: a } - } -- See Note [Naughty record selectors] in TcTyClsDecls - - | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ - | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ - - -- [the only reasons we need to know is so that - -- a) to support isImplicitId - -- b) when desugaring a RecordCon we can get - -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is a superclass selector, - -- or class operation of a class - - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator - | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. - -- Type will be simple: no type families, newtypes, etc - - | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - - | DFunId Bool -- ^ A dictionary function. - -- Bool = True <=> the class has only one method, so may be - -- implemented with a newtype, so it might be bad - -- to be strict on this dictionary - - | CoVarId -- ^ A coercion variable - -- This only covers /un-lifted/ coercions, of type - -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants - | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments - -- Note [Join points] in GHC.Core - --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' - -instance Outputable RecSelParent where - ppr p = case p of - RecSelData ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps - --- | Just a synonym for 'CoVarId'. Written separately so it can be --- exported in the hs-boot file. -coVarDetails :: IdDetails -coVarDetails = CoVarId - --- | Check if an 'IdDetails' says 'CoVarId'. -isCoVarDetails :: IdDetails -> Bool -isCoVarDetails CoVarId = True -isCoVarDetails _ = False - -isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity -isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity -isJoinIdDetails_maybe _ = Nothing - -instance Outputable IdDetails where - ppr = pprIdDetails - -pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails other = brackets (pp other) - where - pp VanillaId = panic "pprIdDetails" - pp (DataConWorkId _) = text "DataCon" - pp (DataConWrapId _) = text "DataConWrapper" - pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" - pp (FCallId _) = text "ForeignCall" - pp (TickBoxOpId _) = text "TickBoxOp" - pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") - pp (RecSelId { sel_naughty = is_naughty }) - = brackets $ text "RecSel" <> - ppWhen is_naughty (text "(naughty)") - pp CoVarId = text "CoVarId" - pp (JoinId arity) = text "JoinId" <> parens (int arity) - -{- -************************************************************************ -* * -\subsection{The main IdInfo type} -* * -************************************************************************ --} - --- | Identifier Information --- --- An 'IdInfo' gives /optional/ information about an 'Id'. If --- present it never lies, but it may not be present, in which case there --- is always a conservative assumption which can be made. --- --- Two 'Id's may have different info even though they have the same --- 'Unique' (and are hence the same 'Id'); for example, one might lack --- the properties attached to the other. --- --- Most of the 'IdInfo' gives information about the value, or definition, of --- the 'Id', independent of its usage. Exceptions to this --- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. --- --- Performance note: when we update 'IdInfo', we have to reallocate this --- entire record, so it is a good idea not to let this data structure get --- too big. -data IdInfo - = IdInfo { - arityInfo :: !ArityInfo, - -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many - -- arguments this 'Id' has to be applied to before it doesn any - -- meaningful work. - ruleInfo :: RuleInfo, - -- ^ Specialisations of the 'Id's function which exist. - -- See Note [Specialisations and RULES in IdInfo] - unfoldingInfo :: Unfolding, - -- ^ The 'Id's unfolding - cafInfo :: CafInfo, - -- ^ 'Id' CAF info - oneShotInfo :: OneShotInfo, - -- ^ Info about a lambda-bound variable, if the 'Id' is one - inlinePragInfo :: InlinePragma, - -- ^ Any inline pragma attached to the 'Id' - occInfo :: OccInfo, - -- ^ How the 'Id' occurs in the program - strictnessInfo :: StrictSig, - -- ^ A strictness signature. Digests how a function uses its arguments - -- if applied to at least 'arityInfo' arguments. - cprInfo :: CprSig, - -- ^ Information on whether the function will ultimately return a - -- freshly allocated constructor. - demandInfo :: Demand, - -- ^ ID demand information - callArityInfo :: !ArityInfo, - -- ^ How this is called. This is the number of arguments to which a - -- binding can be eta-expanded without losing any sharing. - -- n <=> all calls have at least n arguments - levityInfo :: LevityInfo - -- ^ when applied, will this Id ever have a levity-polymorphic type? - } - --- Setters - -setRuleInfo :: IdInfo -> RuleInfo -> IdInfo -setRuleInfo info sp = sp `seq` info { ruleInfo = sp } -setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo -setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } -setOccInfo :: IdInfo -> OccInfo -> IdInfo -setOccInfo info oc = oc `seq` info { occInfo = oc } - -- Try to avoid space leaks by seq'ing - -setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo -setUnfoldingInfo info uf - = -- We don't seq the unfolding, as we generate intermediate - -- unfoldings which are just thrown away, so evaluating them is a - -- waste of time. - -- seqUnfolding uf `seq` - info { unfoldingInfo = uf } - -setArityInfo :: IdInfo -> ArityInfo -> IdInfo -setArityInfo info ar = info { arityInfo = ar } -setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo -setCallArityInfo info ar = info { callArityInfo = ar } -setCafInfo :: IdInfo -> CafInfo -> IdInfo -setCafInfo info caf = info { cafInfo = caf } - -setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo -setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } - -setDemandInfo :: IdInfo -> Demand -> IdInfo -setDemandInfo info dd = dd `seq` info { demandInfo = dd } - -setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo -setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } - -setCprInfo :: IdInfo -> CprSig -> IdInfo -setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } - --- | Basic 'IdInfo' that carries no useful information whatsoever -vanillaIdInfo :: IdInfo -vanillaIdInfo - = IdInfo { - cafInfo = vanillaCafInfo, - arityInfo = unknownArity, - ruleInfo = emptyRuleInfo, - unfoldingInfo = noUnfolding, - oneShotInfo = NoOneShotInfo, - inlinePragInfo = defaultInlinePragma, - occInfo = noOccInfo, - demandInfo = topDmd, - strictnessInfo = nopSig, - cprInfo = topCprSig, - callArityInfo = unknownArity, - levityInfo = NoLevityInfo - } - --- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references -noCafIdInfo :: IdInfo -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs - -- Used for built-in type Ids in MkId. - -{- -************************************************************************ -* * -\subsection[arity-IdInfo]{Arity info about an @Id@} -* * -************************************************************************ - -For locally-defined Ids, the code generator maintains its own notion -of their arities; so it should not be asking... (but other things -besides the code-generator need arity info!) --} - --- | Arity Information --- --- An 'ArityInfo' of @n@ tells us that partial application of this --- 'Id' to up to @n-1@ value arguments does essentially no work. --- --- That is not necessarily the same as saying that it has @n@ leading --- lambdas, because coerces may get in the way. --- --- The arity might increase later in the compilation process, if --- an extra lambda floats up to the binding site. -type ArityInfo = Arity - --- | It is always safe to assume that an 'Id' has an arity of 0 -unknownArity :: Arity -unknownArity = 0 - -ppArityInfo :: Int -> SDoc -ppArityInfo 0 = empty -ppArityInfo n = hsep [text "Arity", int n] - -{- -************************************************************************ -* * -\subsection{Inline-pragma information} -* * -************************************************************************ --} - --- | Inline Pragma Information --- --- Tells when the inlining is active. --- When it is active the thing may be inlined, depending on how --- big it is. --- --- If there was an @INLINE@ pragma, then as a separate matter, the --- RHS will have been made to look small with a Core inline 'Note' --- --- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves --- entirely as a way to inhibit inlining until we want it -type InlinePragInfo = InlinePragma - -{- -************************************************************************ -* * - Strictness -* * -************************************************************************ --} - -pprStrictness :: StrictSig -> SDoc -pprStrictness sig = ppr sig - -{- -************************************************************************ -* * - RuleInfo -* * -************************************************************************ - -Note [Specialisations and RULES in IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, a GlobalId has an *empty* RuleInfo. All their -RULES are contained in the globally-built rule-base. In principle, -one could attach the to M.f the RULES for M.f that are defined in M. -But we don't do that for instance declarations and so we just treat -them all uniformly. - -The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is -just for convenience really. - -However, LocalIds may have non-empty RuleInfo. We treat them -differently because: - a) they might be nested, in which case a global table won't work - b) the RULE might mention free variables, which we use to keep things alive - -In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off -and put in the global list. --} - --- | Rule Information --- --- Records the specializations of this 'Id' that we know about --- in the form of rewrite 'CoreRule's that target them -data RuleInfo - = RuleInfo - [CoreRule] - DVarSet -- Locally-defined free vars of *both* LHS and RHS - -- of rules. I don't think it needs to include the - -- ru_fn though. - -- Note [Rule dependency info] in OccurAnal - --- | Assume that no specializations exist: always safe -emptyRuleInfo :: RuleInfo -emptyRuleInfo = RuleInfo [] emptyDVarSet - -isEmptyRuleInfo :: RuleInfo -> Bool -isEmptyRuleInfo (RuleInfo rs _) = null rs - --- | Retrieve the locally-defined free variables of both the left and --- right hand sides of the specialization rules -ruleInfoFreeVars :: RuleInfo -> DVarSet -ruleInfoFreeVars (RuleInfo _ fvs) = fvs - -ruleInfoRules :: RuleInfo -> [CoreRule] -ruleInfoRules (RuleInfo rules _) = rules - --- | Change the name of the function the rule is keyed on on all of the 'CoreRule's -setRuleInfoHead :: Name -> RuleInfo -> RuleInfo -setRuleInfoHead fn (RuleInfo rules fvs) - = RuleInfo (map (setRuleIdName fn) rules) fvs - -{- -************************************************************************ -* * -\subsection[CG-IdInfo]{Code generator-related information} -* * -************************************************************************ --} - --- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). - --- | Constant applicative form Information --- --- Records whether an 'Id' makes Constant Applicative Form references -data CafInfo - = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: - -- - -- 1. A function or static constructor - -- that refers to one or more CAFs, or - -- - -- 2. A real live CAF - - | NoCafRefs -- ^ A function or static constructor - -- that refers to no CAFs. - deriving (Eq, Ord) - --- | Assumes that the 'Id' has CAF references: definitely safe -vanillaCafInfo :: CafInfo -vanillaCafInfo = MayHaveCafRefs - -mayHaveCafRefs :: CafInfo -> Bool -mayHaveCafRefs MayHaveCafRefs = True -mayHaveCafRefs _ = False - -instance Outputable CafInfo where - ppr = ppCafInfo - -ppCafInfo :: CafInfo -> SDoc -ppCafInfo NoCafRefs = text "NoCafRefs" -ppCafInfo MayHaveCafRefs = empty - -{- -************************************************************************ -* * -\subsection{Bulk operations on IdInfo} -* * -************************************************************************ --} - --- | This is used to remove information on lambda binders that we have --- setup as part of a lambda group, assuming they will be applied all at once, --- but turn out to be part of an unsaturated lambda as in e.g: --- --- > (\x1. \x2. e) arg1 -zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) - | is_safe_occ occ && is_safe_dmd demand - = Nothing - | otherwise - = Just (info {occInfo = safe_occ, demandInfo = topDmd}) - where - -- The "unsafe" occ info is the ones that say I'm not in a lambda - -- because that might not be true for an unsaturated lambda - is_safe_occ occ | isAlwaysTailCalled occ = False - is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False - is_safe_occ _other = True - - safe_occ = case occ of - OneOcc{} -> occ { occ_in_lam = IsInsideLam - , occ_tail = NoTailCallInfo } - IAmALoopBreaker{} - -> occ { occ_tail = NoTailCallInfo } - _other -> occ - - is_safe_dmd dmd = not (isStrictDmd dmd) - --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) - --- | Remove usage (but not strictness) info on the 'IdInfo' -zapUsageInfo :: IdInfo -> Maybe IdInfo -zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) - --- | Remove usage environment info from the strictness signature on the 'IdInfo' -zapUsageEnvInfo :: IdInfo -> Maybe IdInfo -zapUsageEnvInfo info - | hasDemandEnvSig (strictnessInfo info) - = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) - | otherwise - = Nothing - -zapUsedOnceInfo :: IdInfo -> Maybe IdInfo -zapUsedOnceInfo info - = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) - , demandInfo = zapUsedOnceDemand (demandInfo info) } - -zapFragileInfo :: IdInfo -> Maybe IdInfo --- ^ Zap info that depends on free variables -zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) - = new_unf `seq` -- The unfolding field is not (currently) strict, so we - -- force it here to avoid a (zapFragileUnfolding unf) thunk - -- which might leak space - Just (info `setRuleInfo` emptyRuleInfo - `setUnfoldingInfo` new_unf - `setOccInfo` zapFragileOcc occ) - where - new_unf = zapFragileUnfolding unf - -zapFragileUnfolding :: Unfolding -> Unfolding -zapFragileUnfolding unf - | isFragileUnfolding unf = noUnfolding - | otherwise = unf - -zapUnfolding :: Unfolding -> Unfolding --- Squash all unfolding info, preserving only evaluated-ness -zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding - | otherwise = noUnfolding - -zapTailCallInfo :: IdInfo -> Maybe IdInfo -zapTailCallInfo info - = case occInfo info of - occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) - | otherwise -> Nothing - where - safe_occ = occ { occ_tail = NoTailCallInfo } - -zapCallArityInfo :: IdInfo -> IdInfo -zapCallArityInfo info = setCallArityInfo info 0 - -{- -************************************************************************ -* * -\subsection{TickBoxOp} -* * -************************************************************************ --} - -type TickBoxId = Int - --- | Tick box for Hpc-style coverage -data TickBoxOp - = TickBox Module {-# UNPACK #-} !TickBoxId - -instance Outputable TickBoxOp where - ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) - -{- -************************************************************************ -* * - Levity -* * -************************************************************************ - -Note [Levity info] -~~~~~~~~~~~~~~~~~~ - -Ids store whether or not they can be levity-polymorphic at any amount -of saturation. This is helpful in optimizing the levity-polymorphism check -done in the desugarer, where we can usually learn that something is not -levity-polymorphic without actually figuring out its type. See -isExprLevPoly in GHC.Core.Utils for where this info is used. Storing -this is required to prevent perf/compiler/T5631 from blowing up. - --} - --- See Note [Levity info] -data LevityInfo = NoLevityInfo -- always safe - | NeverLevityPolymorphic - deriving Eq - -instance Outputable LevityInfo where - ppr NoLevityInfo = text "NoLevityInfo" - ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" - --- | Marks an IdInfo describing an Id that is never levity polymorphic (even when --- applied). The Type is only there for checking that it's really never levity --- polymorphic -setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo -setNeverLevPoly info ty - = ASSERT2( not (resultIsLevPoly ty), ppr ty ) - info { levityInfo = NeverLevityPolymorphic } - -setLevityInfoWithType :: IdInfo -> Type -> IdInfo -setLevityInfoWithType info ty - | not (resultIsLevPoly ty) - = info { levityInfo = NeverLevityPolymorphic } - | otherwise - = info - -isNeverLevPolyIdInfo :: IdInfo -> Bool -isNeverLevPolyIdInfo info - | NeverLevityPolymorphic <- levityInfo info = True - | otherwise = False diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/IdInfo.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -module IdInfo where -import GhcPrelude -import Outputable -data IdInfo -data IdDetails - -vanillaIdInfo :: IdInfo -coVarDetails :: IdDetails -isCoVarDetails :: IdDetails -> Bool -pprIdDetails :: IdDetails -> SDoc - diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs deleted file mode 100644 --- a/compiler/basicTypes/Lexeme.hs +++ /dev/null @@ -1,240 +0,0 @@ --- (c) The GHC Team --- --- Functions to evaluate whether or not a string is a valid identifier. --- There is considerable overlap between the logic here and the logic --- in Lexer.x, but sadly there seems to be no way to merge them. - -module Lexeme ( - -- * Lexical characteristics of Haskell names - - -- | Use these functions to figure what kind of name a 'FastString' - -- represents; these functions do /not/ check that the identifier - -- is valid. - - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId, - - -- * Validating identifiers - - -- | These functions (working over plain old 'String's) check - -- to make sure that the identifier is valid. - okVarOcc, okConOcc, okTcOcc, - okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc - - -- Some of the exports above are not used within GHC, but may - -- be of value to GHC API users. - - ) where - -import GhcPrelude - -import FastString - -import Data.Char -import qualified Data.Set as Set - -import GHC.Lexeme - -{- - -************************************************************************ -* * - Lexical categories -* * -************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -Note [Classification of generated names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Some names generated for internal use can show up in debugging output, -e.g. when using -ddump-simpl. These generated names start with a $ -but should still be pretty-printed using prefix notation. We make sure -this is the case in isLexVarSym by only classifying a name as a symbol -if all its characters are symbols, not just its first one. --} - -isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) - -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) - -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) - -isLexVarSym fs -- Infix identifiers e.g. "+" - | fs == (fsLit "~R#") = True - | otherwise - = case (if nullFS fs then [] else unpackFS fs) of - [] -> False - (c:cs) -> startsVarSym c && all isVarSymChar cs - -- See Note [Classification of generated names] - -{- - -************************************************************************ -* * - Detecting valid names for Template Haskell -* * -************************************************************************ - --} - ----------------------- --- External interface ----------------------- - --- | Is this an acceptable variable name? -okVarOcc :: String -> Bool -okVarOcc str@(c:_) - | startsVarId c - = okVarIdOcc str - | startsVarSym c - = okVarSymOcc str -okVarOcc _ = False - --- | Is this an acceptable constructor name? -okConOcc :: String -> Bool -okConOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | str == "[]" - = True -okConOcc _ = False - --- | Is this an acceptable type name? -okTcOcc :: String -> Bool -okTcOcc "[]" = True -okTcOcc "->" = True -okTcOcc "~" = True -okTcOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | startsVarSym c - = okVarSymOcc str -okTcOcc _ = False - --- | Is this an acceptable alphanumeric variable name, assuming it starts --- with an acceptable letter? -okVarIdOcc :: String -> Bool -okVarIdOcc str = okIdOcc str && - -- admit "_" as a valid identifier. Required to support typed - -- holes in Template Haskell. See #10267 - (str == "_" || not (str `Set.member` reservedIds)) - --- | Is this an acceptable symbolic variable name, assuming it starts --- with an acceptable character? -okVarSymOcc :: String -> Bool -okVarSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) && - not (isDashes str) - --- | Is this an acceptable alphanumeric constructor name, assuming it --- starts with an acceptable letter? -okConIdOcc :: String -> Bool -okConIdOcc str = okIdOcc str || - is_tuple_name1 True str || - -- Is it a boxed tuple... - is_tuple_name1 False str || - -- ...or an unboxed tuple (#12407)... - is_sum_name1 str - -- ...or an unboxed sum (#12514)? - where - -- check for tuple name, starting at the beginning - is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest - is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest - is_tuple_name1 _ _ = False - - -- check for tuple tail - is_tuple_name2 True ")" = True - is_tuple_name2 False "#)" = True - is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest - is_tuple_name2 boxed (ws : rest) - | isSpace ws = is_tuple_name2 boxed rest - is_tuple_name2 _ _ = False - - -- check for sum name, starting at the beginning - is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest - is_sum_name1 _ = False - - -- check for sum tail, only allowing at most one underscore - is_sum_name2 _ "#)" = True - is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest - is_sum_name2 False ('_' : rest) = is_sum_name2 True rest - is_sum_name2 underscore (ws : rest) - | isSpace ws = is_sum_name2 underscore rest - is_sum_name2 _ _ = False - --- | Is this an acceptable symbolic constructor name, assuming it --- starts with an acceptable character? -okConSymOcc :: String -> Bool -okConSymOcc ":" = True -okConSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) - ----------------------- --- Internal functions ----------------------- - --- | Is this string an acceptable id, possibly with a suffix of hashes, --- but not worrying about case or clashing with reserved words? -okIdOcc :: String -> Bool -okIdOcc str - = let hashes = dropWhile okIdChar str in - all (== '#') hashes -- -XMagicHash allows a suffix of hashes - -- of course, `all` says "True" to an empty list - --- | Is this character acceptable in an identifier (after the first letter)? --- See alexGetByte in Lexer.x -okIdChar :: Char -> Bool -okIdChar c = case generalCategory c of - UppercaseLetter -> True - LowercaseLetter -> True - TitlecaseLetter -> True - ModifierLetter -> True -- See #10196 - OtherLetter -> True -- See #1103 - NonSpacingMark -> True -- See #7650 - DecimalNumber -> True - OtherNumber -> True -- See #4373 - _ -> c == '\'' || c == '_' - --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. -reservedIds :: Set.Set String -reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" - , "do", "else", "foreign", "if", "import", "in" - , "infix", "infixl", "infixr", "instance", "let" - , "module", "newtype", "of", "then", "type", "where" - , "_" ] - --- | All reserved operators. Taken from section 2.4 of the 2010 Report. -reservedOps :: Set.Set String -reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" - , "@", "~", "=>" ] - --- | Does this string contain only dashes and has at least 2 of them? -isDashes :: String -> Bool -isDashes ('-' : '-' : rest) = all (== '-') rest -isDashes _ = False diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs deleted file mode 100644 --- a/compiler/basicTypes/Literal.hs +++ /dev/null @@ -1,851 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[Literal]{@Literal@: literals} --} - -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Literal - ( - -- * Main data type - Literal(..) -- Exported to ParseIface - , LitNumType(..) - - -- ** Creating Literals - , mkLitInt, mkLitIntWrap, mkLitIntWrapC - , mkLitWord, mkLitWordWrap, mkLitWordWrapC - , mkLitInt64, mkLitInt64Wrap - , mkLitWord64, mkLitWord64Wrap - , mkLitFloat, mkLitDouble - , mkLitChar, mkLitString - , mkLitInteger, mkLitNatural - , mkLitNumber, mkLitNumberWrap - - -- ** Operations on Literals - , literalType - , absentLiteralOf - , pprLiteral - , litNumIsSigned - , litNumCheckRange - - -- ** Predicates on Literals and their contents - , litIsDupable, litIsTrivial, litIsLifted - , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange - , isZeroLit - , litFitsInChar - , litValue, isLitValue, isLitValue_maybe, mapLitValue - - -- ** Coercions - , word2IntLit, int2WordLit - , narrowLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TysPrim -import PrelNames -import Type -import TyCon -import Outputable -import FastString -import BasicTypes -import Binary -import Constants -import GHC.Driver.Session -import GHC.Platform -import UniqFM -import Util - -import Data.ByteString (ByteString) -import Data.Int -import Data.Word -import Data.Char -import Data.Maybe ( isJust ) -import Data.Data ( Data ) -import Data.Proxy -import Numeric ( fromRat ) - -{- -************************************************************************ -* * -\subsection{Literals} -* * -************************************************************************ --} - --- | So-called 'Literal's are one of: --- --- * An unboxed numeric literal or floating-point literal which is presumed --- to be surrounded by appropriate constructors (@Int#@, etc.), so that --- the overall thing makes sense. --- --- We maintain the invariant that the 'Integer' in the 'LitNumber' --- constructor is actually in the (possibly target-dependent) range. --- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying --- the target machine's wrapping semantics. Use these in situations --- where you know the wrapping semantics are correct. --- --- * The literal derived from the label mentioned in a \"foreign label\" --- declaration ('LitLabel') --- --- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' --- (i.e. 'MutVar#') when the the value is never used. --- --- * A character --- * A string --- * The NULL pointer --- -data Literal - = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with - -- 'mkLitChar' - - | LitNumber !LitNumType !Integer Type - -- ^ Any numeric literal that can be - -- internally represented with an Integer. - -- See Note [Types of LitNumbers] below for the - -- Type field. - - | LitString ByteString -- ^ A string-literal: stored and emitted - -- UTF-8 encoded, we'll arrange to decode it - -- at runtime. Also emitted with a @\'\\0\'@ - -- terminator. Create with 'mkLitString' - - | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value - -- that can be represented as a Literal. Create - -- with 'nullAddrLit' - - | LitRubbish -- ^ A nonsense value, used when an unlifted - -- binding is absent and has type - -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. - -- May be lowered by code-gen to any possible - -- value. Also see Note [Rubbish literals] - - | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' - | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' - - | LitLabel FastString (Maybe Int) FunctionOrData - -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the - -- declaration - -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\@ will - -- be appended to label name when emitting - -- assembly. - -- - -- 3) Flag indicating whether the symbol - -- references a function or a data - deriving Data - --- | Numeric literal type -data LitNumType - = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) - | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) - | LitNumInt -- ^ @Int#@ - according to target machine - | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits - | LitNumWord -- ^ @Word#@ - according to target machine - | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits - deriving (Data,Enum,Eq,Ord) - --- | Indicate if a numeric literal type supports negative numbers -litNumIsSigned :: LitNumType -> Bool -litNumIsSigned nt = case nt of - LitNumInteger -> True - LitNumNatural -> False - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> False - LitNumWord64 -> False - -{- -Note [Integer literals] -~~~~~~~~~~~~~~~~~~~~~~~ -An Integer literal is represented using, well, an Integer, to make it -easier to write RULEs for them. They also contain the Integer type, so -that e.g. literalType can return the right Type for them. - -They only get converted into real Core, - mkInteger [c1, c2, .., cn] -during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the -core will be, so that it can see whether it involves CAFs. - -When we initially build an Integer literal, notably when -deserialising it from an interface file (see the Binary instance -below), we don't have convenient access to the mkInteger Id. So we -just use an error thunk, and fill in the real Id when we do tcIfaceLit -in GHC.IfaceToCore. - -Note [Natural literals] -~~~~~~~~~~~~~~~~~~~~~~~ -Similar to Integer literals. - -Note [String literals] -~~~~~~~~~~~~~~~~~~~~~~ - -String literals are UTF-8 encoded and stored into ByteStrings in the following -ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals -with the BytesPrimL constructor (see #14741). - -It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite -bad for performance with large strings (see #16198 and #14741). - -To include string literals into output objects, the assembler code generator has -to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] -for more details. - --} - -instance Binary LitNumType where - put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) - get bh = do - h <- getByte bh - return (toEnum (fromIntegral h)) - -instance Binary Literal where - put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa - put_ bh (LitString ab) = do putByte bh 1; put_ bh ab - put_ bh (LitNullAddr) = do putByte bh 2 - put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah - put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (LitLabel aj mb fod) - = do putByte bh 5 - put_ bh aj - put_ bh mb - put_ bh fod - put_ bh (LitNumber nt i _) - = do putByte bh 6 - put_ bh nt - put_ bh i - put_ bh (LitRubbish) = do putByte bh 7 - get bh = do - h <- getByte bh - case h of - 0 -> do - aa <- get bh - return (LitChar aa) - 1 -> do - ab <- get bh - return (LitString ab) - 2 -> do - return (LitNullAddr) - 3 -> do - ah <- get bh - return (LitFloat ah) - 4 -> do - ai <- get bh - return (LitDouble ai) - 5 -> do - aj <- get bh - mb <- get bh - fod <- get bh - return (LitLabel aj mb fod) - 6 -> do - nt <- get bh - i <- get bh - -- Note [Types of LitNumbers] - let t = case nt of - LitNumInt -> intPrimTy - LitNumInt64 -> int64PrimTy - LitNumWord -> wordPrimTy - LitNumWord64 -> word64PrimTy - -- See Note [Integer literals] - LitNumInteger -> - panic "Evaluated the place holder for mkInteger" - -- and Note [Natural literals] - LitNumNatural -> - panic "Evaluated the place holder for mkNatural" - return (LitNumber nt i t) - _ -> do - return (LitRubbish) - -instance Outputable Literal where - ppr = pprLiteral id - -instance Eq Literal where - a == b = compare a b == EQ - --- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in --- 'TrieMap.CoreMap'. -instance Ord Literal where - compare = cmpLit - -{- - Construction - ~~~~~~~~~~~~ --} - -{- Note [Word/Int underflow/overflow] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and -unsigned integral types): "All arithmetic is performed modulo 2^n, where n is -the number of bits in the type." - -GHC stores Word# and Int# constant values as Integer. Core optimizations such -as constant folding must ensure that the Integer value remains in the valid -target Word/Int range (see #13172). The following functions are used to -ensure this. - -Note that we *don't* warn the user about overflow. It's not done at runtime -either, and compilation of completely harmless things like - ((124076834 :: Word32) + (2147483647 :: Word32)) -doesn't yield a warning. Instead we simply squash the value into the *target* -Int/Word range. --} - --- | Wrap a literal number according to its type -wrapLitNumber :: DynFlags -> Literal -> Literal -wrapLitNumber dflags v@(LitNumber nt i t) = case nt of - LitNumInt -> case platformWordSize (targetPlatform dflags) of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord -> case platformWordSize (targetPlatform dflags) of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInteger -> v - LitNumNatural -> v -wrapLitNumber _ x = x - --- | Create a numeric 'Literal' of the given type -mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal -mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t) - --- | Check that a given number is in the range of a numeric literal -litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool -litNumCheckRange dflags nt i = case nt of - LitNumInt -> inIntRange dflags i - LitNumWord -> inWordRange dflags i - LitNumInt64 -> inInt64Range i - LitNumWord64 -> inWord64Range i - LitNumNatural -> i >= 0 - LitNumInteger -> True - --- | Create a numeric 'Literal' of the given type -mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal -mkLitNumber dflags nt i t = - ASSERT2(litNumCheckRange dflags nt i, integer i) - (LitNumber nt i t) - --- | Creates a 'Literal' of type @Int#@ -mkLitInt :: DynFlags -> Integer -> Literal -mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x ) - (mkLitIntUnchecked x) - --- | Creates a 'Literal' of type @Int#@. --- If the argument is out of the (target-dependent) range, it is wrapped. --- See Note [Word/Int underflow/overflow] -mkLitIntWrap :: DynFlags -> Integer -> Literal -mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i - --- | Creates a 'Literal' of type @Int#@ without checking its range. -mkLitIntUnchecked :: Integer -> Literal -mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy - --- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating --- overflow. That is, if the argument is out of the (target-dependent) range --- the argument is wrapped and the overflow flag will be set. --- See Note [Word/Int underflow/overflow] -mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkLitIntWrapC dflags i = (n, i /= i') - where - n@(LitNumber _ i' _) = mkLitIntWrap dflags i - --- | Creates a 'Literal' of type @Word#@ -mkLitWord :: DynFlags -> Integer -> Literal -mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x ) - (mkLitWordUnchecked x) - --- | Creates a 'Literal' of type @Word#@. --- If the argument is out of the (target-dependent) range, it is wrapped. --- See Note [Word/Int underflow/overflow] -mkLitWordWrap :: DynFlags -> Integer -> Literal -mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i - --- | Creates a 'Literal' of type @Word#@ without checking its range. -mkLitWordUnchecked :: Integer -> Literal -mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy - --- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating --- carry. That is, if the argument is out of the (target-dependent) range --- the argument is wrapped and the carry flag will be set. --- See Note [Word/Int underflow/overflow] -mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkLitWordWrapC dflags i = (n, i /= i') - where - n@(LitNumber _ i' _) = mkLitWordWrap dflags i - --- | Creates a 'Literal' of type @Int64#@ -mkLitInt64 :: Integer -> Literal -mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) - --- | Creates a 'Literal' of type @Int64#@. --- If the argument is out of the range, it is wrapped. -mkLitInt64Wrap :: DynFlags -> Integer -> Literal -mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i - --- | Creates a 'Literal' of type @Int64#@ without checking its range. -mkLitInt64Unchecked :: Integer -> Literal -mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy - --- | Creates a 'Literal' of type @Word64#@ -mkLitWord64 :: Integer -> Literal -mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) - --- | Creates a 'Literal' of type @Word64#@. --- If the argument is out of the range, it is wrapped. -mkLitWord64Wrap :: DynFlags -> Integer -> Literal -mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i - --- | Creates a 'Literal' of type @Word64#@ without checking its range. -mkLitWord64Unchecked :: Integer -> Literal -mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy - --- | Creates a 'Literal' of type @Float#@ -mkLitFloat :: Rational -> Literal -mkLitFloat = LitFloat - --- | Creates a 'Literal' of type @Double#@ -mkLitDouble :: Rational -> Literal -mkLitDouble = LitDouble - --- | Creates a 'Literal' of type @Char#@ -mkLitChar :: Char -> Literal -mkLitChar = LitChar - --- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to --- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ -mkLitString :: String -> Literal --- stored UTF-8 encoded -mkLitString s = LitString (bytesFS $ mkFastString s) - -mkLitInteger :: Integer -> Type -> Literal -mkLitInteger x ty = LitNumber LitNumInteger x ty - -mkLitNatural :: Integer -> Type -> Literal -mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) - (LitNumber LitNumNatural x ty) - -inIntRange, inWordRange :: DynFlags -> Integer -> Bool -inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags -inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags - -inNaturalRange :: Integer -> Bool -inNaturalRange x = x >= 0 - -inInt64Range, inWord64Range :: Integer -> Bool -inInt64Range x = x >= toInteger (minBound :: Int64) && - x <= toInteger (maxBound :: Int64) -inWord64Range x = x >= toInteger (minBound :: Word64) && - x <= toInteger (maxBound :: Word64) - -inCharRange :: Char -> Bool -inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR - --- | Tests whether the literal represents a zero of whatever type it is -isZeroLit :: Literal -> Bool -isZeroLit (LitNumber _ 0 _) = True -isZeroLit (LitFloat 0) = True -isZeroLit (LitDouble 0) = True -isZeroLit _ = False - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. -litValue :: Literal -> Integer -litValue l = case isLitValue_maybe l of - Just x -> x - Nothing -> pprPanic "litValue" (ppr l) - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char' and numbers. -isLitValue_maybe :: Literal -> Maybe Integer -isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c -isLitValue_maybe (LitNumber _ i _) = Just i -isLitValue_maybe _ = Nothing - --- | Apply a function to the 'Integer' contained in the 'Literal', for when that --- makes sense, e.g. for 'Char' and numbers. --- For fixed-size integral literals, the result will be wrapped in accordance --- with the semantics of the target type. --- See Note [Word/Int underflow/overflow] -mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (LitChar c) = mkLitChar (fchar c) - where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags - (LitNumber nt (f i) t) -mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) - --- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', --- 'Int', 'Word', 'LitInteger' and 'LitNatural'. -isLitValue :: Literal -> Bool -isLitValue = isJust . isLitValue_maybe - -{- - Coercions - ~~~~~~~~~ --} - -narrow8IntLit, narrow16IntLit, narrow32IntLit, - narrow8WordLit, narrow16WordLit, narrow32WordLit, - char2IntLit, int2CharLit, - float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, - float2DoubleLit, double2FloatLit - :: Literal -> Literal - -word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal -word2IntLit dflags (LitNumber LitNumWord w _) - -- Map Word range [max_int+1, max_word] - -- to Int range [min_int , -1] - -- Range [0,max_int] has the same representation with both Int and Word - | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1) - | otherwise = mkLitInt dflags w -word2IntLit _ l = pprPanic "word2IntLit" (ppr l) - -int2WordLit dflags (LitNumber LitNumInt i _) - -- Map Int range [min_int , -1] - -- to Word range [max_int+1, max_word] - -- Range [0,max_int] has the same representation with both Int and Word - | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i) - | otherwise = mkLitWord dflags i -int2WordLit _ l = pprPanic "int2WordLit" (ppr l) - --- | Narrow a literal number (unchecked result range) -narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal -narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t -narrowLit _ l = pprPanic "narrowLit" (ppr l) - -narrow8IntLit = narrowLit (Proxy :: Proxy Int8) -narrow16IntLit = narrowLit (Proxy :: Proxy Int16) -narrow32IntLit = narrowLit (Proxy :: Proxy Int32) -narrow8WordLit = narrowLit (Proxy :: Proxy Word8) -narrow16WordLit = narrowLit (Proxy :: Proxy Word16) -narrow32WordLit = narrowLit (Proxy :: Proxy Word32) - -char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) -char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) -int2CharLit l = pprPanic "int2CharLit" (ppr l) - -float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) -float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) -int2FloatLit l = pprPanic "int2FloatLit" (ppr l) - -double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) -double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) -int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) - -float2DoubleLit (LitFloat f) = LitDouble f -float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) -double2FloatLit (LitDouble d) = LitFloat d -double2FloatLit l = pprPanic "double2FloatLit" (ppr l) - -nullAddrLit :: Literal -nullAddrLit = LitNullAddr - --- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. -rubbishLit :: Literal -rubbishLit = LitRubbish - -{- - Predicates - ~~~~~~~~~~ --} - --- | True if there is absolutely no penalty to duplicating the literal. --- False principally of strings. --- --- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would --- blow up code sizes. Not only this, it's also unsafe. --- --- Consider a program that wants to traverse a string. One way it might do this --- is to first compute the Addr# pointing to the end of the string, and then, --- starting from the beginning, bump a pointer using eqAddr# to determine the --- end. For instance, --- --- @ --- -- Given pointers to the start and end of a string, count how many zeros --- -- the string contains. --- countZeros :: Addr# -> Addr# -> -> Int --- countZeros start end = go start 0 --- where --- go off n --- | off `addrEq#` end = n --- | otherwise = go (off `plusAddr#` 1) n' --- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 --- | otherwise = n --- @ --- --- Consider what happens if we considered strings to be trivial (and therefore --- duplicable) and emitted a call like @countZeros "hello"# ("hello"# --- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same --- string, meaning that an iteration like the above would blow up terribly. --- This is what happened in #12757. --- --- Ultimately the solution here is to make primitive strings a bit more --- structured, ensuring that the compiler can't inline in ways that will break --- user code. One approach to this is described in #8472. -litIsTrivial :: Literal -> Bool --- c.f. GHC.Core.Utils.exprIsTrivial -litIsTrivial (LitString _) = False -litIsTrivial (LitNumber nt _ _) = case nt of - LitNumInteger -> False - LitNumNatural -> False - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True -litIsTrivial _ = True - --- | True if code space does not go bad if we duplicate this literal -litIsDupable :: DynFlags -> Literal -> Bool --- c.f. GHC.Core.Utils.exprIsDupable -litIsDupable _ (LitString _) = False -litIsDupable dflags (LitNumber nt i _) = case nt of - LitNumInteger -> inIntRange dflags i - LitNumNatural -> inIntRange dflags i - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True -litIsDupable _ _ = True - -litFitsInChar :: Literal -> Bool -litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) - && i <= toInteger (ord maxBound) -litFitsInChar _ = False - -litIsLifted :: Literal -> Bool -litIsLifted (LitNumber nt _ _) = case nt of - LitNumInteger -> True - LitNumNatural -> True - LitNumInt -> False - LitNumInt64 -> False - LitNumWord -> False - LitNumWord64 -> False -litIsLifted _ = False - -{- - Types - ~~~~~ - -Note [Types of LitNumbers] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A LitNumber's type is always known from its LitNumType: - - LitNumInteger -> Integer - LitNumNatural -> Natural - LitNumInt -> Int# (intPrimTy) - LitNumInt64 -> Int64# (int64PrimTy) - LitNumWord -> Word# (wordPrimTy) - LitNumWord64 -> Word64# (word64PrimTy) - -The reason why we have a Type field is because Integer and Natural types live -outside of GHC (in the libraries), so we have to get the actual Type via -lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites -of literalType, so we do that when creating these literals, and literalType -simply reads the field. - -(But see also Note [Integer literals] and Note [Natural literals]) --} - --- | Find the Haskell 'Type' the literal occupies -literalType :: Literal -> Type -literalType LitNullAddr = addrPrimTy -literalType (LitChar _) = charPrimTy -literalType (LitString _) = addrPrimTy -literalType (LitFloat _) = floatPrimTy -literalType (LitDouble _) = doublePrimTy -literalType (LitLabel _ _ _) = addrPrimTy -literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] -literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) - where - a = alphaTyVarUnliftedRep - -absentLiteralOf :: TyCon -> Maybe Literal --- Return a literal of the appropriate primitive --- TyCon, to use as a placeholder when it doesn't matter --- Rubbish literals are handled in WwLib, because --- 1. Looking at the TyCon is not enough, we need the actual type --- 2. This would need to return a type application to a literal -absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) - -absent_lits :: UniqFM Literal -absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) - , (charPrimTyConKey, LitChar 'x') - , (intPrimTyConKey, mkLitIntUnchecked 0) - , (int64PrimTyConKey, mkLitInt64Unchecked 0) - , (wordPrimTyConKey, mkLitWordUnchecked 0) - , (word64PrimTyConKey, mkLitWord64Unchecked 0) - , (floatPrimTyConKey, LitFloat 0) - , (doublePrimTyConKey, LitDouble 0) - ] - -{- - Comparison - ~~~~~~~~~~ --} - -cmpLit :: Literal -> Literal -> Ordering -cmpLit (LitChar a) (LitChar b) = a `compare` b -cmpLit (LitString a) (LitString b) = a `compare` b -cmpLit (LitNullAddr) (LitNullAddr) = EQ -cmpLit (LitFloat a) (LitFloat b) = a `compare` b -cmpLit (LitDouble a) (LitDouble b) = a `compare` b -cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b -cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) - | nt1 == nt2 = a `compare` b - | otherwise = nt1 `compare` nt2 -cmpLit (LitRubbish) (LitRubbish) = EQ -cmpLit lit1 lit2 - | litTag lit1 < litTag lit2 = LT - | otherwise = GT - -litTag :: Literal -> Int -litTag (LitChar _) = 1 -litTag (LitString _) = 2 -litTag (LitNullAddr) = 3 -litTag (LitFloat _) = 4 -litTag (LitDouble _) = 5 -litTag (LitLabel _ _ _) = 6 -litTag (LitNumber {}) = 7 -litTag (LitRubbish) = 8 - -{- - Printing - ~~~~~~~~ -* See Note [Printing of literals in Core] --} - -pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc -pprLiteral _ (LitChar c) = pprPrimChar c -pprLiteral _ (LitString s) = pprHsBytes s -pprLiteral _ (LitNullAddr) = text "__NULL" -pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix -pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitNumber nt i _) - = case nt of - LitNumInteger -> pprIntegerVal add_par i - LitNumNatural -> pprIntegerVal add_par i - LitNumInt -> pprPrimInt i - LitNumInt64 -> pprPrimInt64 i - LitNumWord -> pprPrimWord i - LitNumWord64 -> pprPrimWord64 i -pprLiteral add_par (LitLabel l mb fod) = - add_par (text "__label" <+> b <+> ppr fod) - where b = case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLiteral _ (LitRubbish) = text "__RUBBISH" - -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc --- See Note [Printing of literals in Core]. -pprIntegerVal add_par i | i < 0 = add_par (integer i) - | otherwise = integer i - -{- -Note [Printing of literals in Core] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function `add_par` is used to wrap parenthesis around negative integers -(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring -an atomic thing (for example function application). - -Although not all Core literals would be valid Haskell, we are trying to stay -as close as possible to Haskell syntax in the printing of Core, to make it -easier for a Haskell user to read Core. - -To that end: - * We do print parenthesis around negative `LitInteger`, because we print - `LitInteger` using plain number literals (no prefix or suffix), and plain - number literals in Haskell require parenthesis in contexts like function - application (i.e. `1 - -1` is not valid Haskell). - - * We don't print parenthesis around other (negative) literals, because they - aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's - parser). - -Literal Output Output if context requires - an atom (if different) -------- ------- ---------------------- -LitChar 'a'# -LitString "aaa"# -LitNullAddr "__NULL" -LitInt -1# -LitInt64 -1L# -LitWord 1## -LitWord64 1L## -LitFloat -1.0# -LitDouble -1.0## -LitInteger -1 (-1) -LitLabel "__label" ... ("__label" ...) -LitRubbish "__RUBBISH" - -Note [Rubbish literals] -~~~~~~~~~~~~~~~~~~~~~~~ -During worker/wrapper after demand analysis, where an argument -is unused (absent) we do the following w/w split (supposing that -y is absent): - - f x y z = e -===> - f x y z = $wf x z - $wf x z = let y = - in e - -Usually the binding for y is ultimately optimised away, and -even if not it should never be evaluated -- but that's the -way the w/w split starts off. - -What is ? -* For lifted values can be a call to 'error'. -* For primitive types like Int# or Word# we can use any random - value of that type. -* But what about /unlifted/ but /boxed/ types like MutVar# or - Array#? We need a literal value of that type. - -That is 'LitRubbish'. Since we need a rubbish literal for -many boxed, unlifted types, we say that LitRubbish has type - LitRubbish :: forall (a :: TYPE UnliftedRep). a - -So we might see a w/w split like - $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) - in e - -Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted -heap pointers. - -Here are the moving parts: - -* We define LitRubbish as a constructor in Literal.Literal - -* It is given its polymorphic type by Literal.literalType - -* WwLib.mk_absent_let introduces a LitRubbish for absent - arguments of boxed, unlifted type. - -* In CoreToSTG we convert (RubishLit @t) to just (). STG is - untyped, so it doesn't matter that it points to a lifted - value. The important thing is that it is a heap pointer, - which the garbage collector can follow if it encounters it. - - We considered maintaining LitRubbish in STG, and lowering - it in the code generators, but it seems simpler to do it - once and for all in CoreToSTG. - - In GHC.ByteCode.Asm we just lower it as a 0 literal, because - it's all boxed and lifted to the host GC anyway. --} diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs deleted file mode 100644 --- a/compiler/basicTypes/MkId.hs +++ /dev/null @@ -1,1708 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -This module contains definitions for the IdInfo for things that -have a standard form, namely: - -- data constructors -- record selectors -- method and superclass selectors -- primitive operations --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module MkId ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, - - mkPrimOpId, mkFCallId, - - unwrapNewTypeBody, wrapFamInstBody, - DataConBoxer(..), vanillaDataConBoxer, - mkDataConRep, mkDataConWorkId, - - -- And some particular Ids; see below for why they are wired in - wiredInIds, ghcPrimIds, - realWorldPrimId, - voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, - coercionTokenId, magicDictId, coerceId, - proxyHashId, noinlineId, noinlineIdName, - coerceName, - - -- Re-export error Ids - module PrelRules - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core.Rules -import TysPrim -import TysWiredIn -import PrelRules -import Type -import TyCoRep -import FamInstEnv -import Coercion -import TcType -import GHC.Core.Make -import GHC.Core.Utils ( mkCast, mkDefaultCase ) -import GHC.Core.Unfold -import Literal -import TyCon -import Class -import NameSet -import Name -import PrimOp -import ForeignCall -import DataCon -import Id -import IdInfo -import Demand -import Cpr -import GHC.Core -import Unique -import UniqSupply -import PrelNames -import BasicTypes hiding ( SuccessFlag(..) ) -import Util -import GHC.Driver.Session -import Outputable -import FastString -import ListSetOps -import Var (VarBndr(Bndr)) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Maybe ( maybeToList ) - -{- -************************************************************************ -* * -\subsection{Wired in Ids} -* * -************************************************************************ - -Note [Wired-in Ids] -~~~~~~~~~~~~~~~~~~~ -A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') -rather than by looking it up its name in some environment or fetching -it from an interface file. - -There are several reasons why an Id might appear in the wiredInIds: - -* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] - -* magicIds: see Note [magicIds] - -* errorIds, defined in GHC.Core.Make. - These error functions (e.g. rUNTIME_ERROR_ID) are wired in - because the desugarer generates code that mentions them directly - -In all cases except ghcPrimIds, there is a definition site in a -library module, which may be called (e.g. in higher order situations); -but the wired-in version means that the details are never read from -that module's interface file; instead, the full definition is right -here. - -Note [ghcPrimIds (aka pseudoops)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ghcPrimIds - - * Are exported from GHC.Prim - - * Can't be defined in Haskell, and hence no Haskell binding site, - but have perfectly reasonable unfoldings in Core - - * Either have a CompulsoryUnfolding (hence always inlined), or - of an EvaldUnfolding and void representation (e.g. void#) - - * Are (or should be) defined in primops.txt.pp as 'pseudoop' - Reason: that's how we generate documentation for them - -Note [magicIds] -~~~~~~~~~~~~~~~ -The magicIds - - * Are exported from GHC.Magic - - * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). - This definition at least generates Haddock documentation for them. - - * May or may not have a CompulsoryUnfolding. - - * But have some special behaviour that can't be done via an - unfolding from an interface file --} - -wiredInIds :: [Id] -wiredInIds - = magicIds - ++ ghcPrimIds - ++ errorIds -- Defined in GHC.Core.Make - -magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId] - -ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] -ghcPrimIds - = [ realWorldPrimId - , voidPrimId - , nullAddrId - , seqId - , magicDictId - , coerceId - , proxyHashId - ] - -{- -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ - -The wrapper for a constructor is an ordinary top-level binding that evaluates -any strict args, unboxes any args that are going to be flattened, and calls -the worker. - -We're going to build a constructor that looks like: - - data (Data a, C b) => T a b = T1 !a !Int b - - T1 = /\ a b -> - \d1::Data a, d2::C b -> - \p q r -> case p of { p -> - case q of { q -> - Con T1 [a,b] [p,q,r]}} - -Notice that - -* d2 is thrown away --- a context in a data decl is used to make sure - one *could* construct dictionaries at the site the constructor - is used, but the dictionary isn't actually used. - -* We have to check that we can construct Data dictionaries for - the types a and Int. Once we've done that we can throw d1 away too. - -* We use (case p of q -> ...) to evaluate p, rather than "seq" because - all that matters is that the arguments are evaluated. "seq" is - very careful to preserve evaluation order, which we don't need - to be here. - - You might think that we could simply give constructors some strictness - info, like PrimOps, and let CoreToStg do the let-to-case transformation. - But we don't do that because in the case of primops and functions strictness - is a *property* not a *requirement*. In the case of constructors we need to - do something active to evaluate the argument. - - Making an explicit case expression allows the simplifier to eliminate - it in the (common) case where the constructor arg is already evaluated. - -Note [Wrappers for data instance tycons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of data instances, the wrapper also applies the coercion turning -the representation type into the family instance type to cast the result of -the wrapper. For example, consider the declarations - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -The tycon to which the datacon MapPair belongs gets a unique internal -name of the form :R123Map, and we call it the representation tycon. -In contrast, Map is the family tycon (accessible via -tyConFamInst_maybe). A coercion allows you to move between -representation and family type. It is accessible from :R123Map via -tyConFamilyCoercion_maybe and has kind - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -The wrapper and worker of MapPair get the types - - -- Wrapper - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) - - -- Worker - MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -This coercion is conditionally applied by wrapFamInstBody. - -It's a bit more complicated if the data instance is a GADT as well! - - data instance T [a] where - T1 :: forall b. b -> T [Maybe b] - -Hence we translate to - - -- Wrapper - $WT1 :: forall b. b -> T [Maybe b] - $WT1 b v = T1 (Maybe b) b (Maybe b) v - `cast` sym (Co7T (Maybe b)) - - -- Worker - T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c - - -- Coercion from family type to representation type - Co7T a :: T [a] ~ :R7T a - -Newtype instances through an additional wrinkle into the mix. Consider the -following example (adapted from #15318, comment:2): - - data family T a - newtype instance T [a] = MkT [a] - -Within the newtype instance, there are three distinct types at play: - -1. The newtype's underlying type, [a]. -2. The instance's representation type, TList a (where TList is the - representation tycon). -3. The family type, T [a]. - -We need two coercions in order to cast from (1) to (3): - -(a) A newtype coercion axiom: - - axiom coTList a :: TList a ~ [a] - - (Where TList is the representation tycon of the newtype instance.) - -(b) A data family instance coercion axiom: - - axiom coT a :: T [a] ~ TList a - -When we translate the newtype instance to Core, we obtain: - - -- Wrapper - $WMkT :: forall a. [a] -> T [a] - $WMkT a x = MkT a x |> Sym (coT a) - - -- Worker - MkT :: forall a. [a] -> TList [a] - MkT a x = x |> Sym (coTList a) - -Unlike for data instances, the worker for a newtype instance is actually an -executable function which expands to a cast, but otherwise, the general -strategy is essentially the same as for data instances. Also note that we have -a wrapper, which is unusual for a newtype, but we make GHC produce one anyway -for symmetry with the way data instances are handled. - -Note [Newtype datacons] -~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from - class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. - -Note [Newtype workers] -~~~~~~~~~~~~~~~~~~~~~~ -A newtype does not really have a worker. Instead, newtype constructors -just unfold into a cast. But we need *something* for, say, MkAge to refer -to. So, we do this: - -* The Id used as the newtype worker will have a compulsory unfolding to - a cast. See Note [Compulsory newtype unfolding] - -* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, - as those have special treatment in the back end. - -* There is no top-level binding, because the compulsory unfolding - means that it will be inlined (to a cast) at every call site. - -We probably should have a NewtypeWorkId, but these Ids disappear as soon as -we desugar anyway, so it seems a step too far. - -Note [Compulsory newtype unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype wrappers, just like workers, have compulsory unfoldings. -This is needed so that two optimizations involving newtypes have the same -effect whether a wrapper is present or not: - -(1) Case-of-known constructor. - See Note [beta-reduction in exprIsConApp_maybe]. - -(2) Matching against the map/coerce RULE. Suppose we have the RULE - - {-# RULE "map/coerce" map coerce = ... #-} - - As described in Note [Getting the map/coerce RULE to work], - the occurrence of 'coerce' is transformed into: - - {-# RULE "map/coerce" forall (c :: T1 ~R# T2). - map ((\v -> v) `cast` c) = ... #-} - - We'd like 'map Age' to match the LHS. For this to happen, Age - must be unfolded, otherwise we'll be stuck. This is tested in T16208. - -It also allows for the posssibility of levity polymorphic newtypes -with wrappers (with -XUnliftedNewtypes): - - newtype N (a :: TYPE r) = MkN a - -With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- -polymorphic. It's OK because MkN evaporates in the compiled code, becoming -just a cast. That is, it has a compulsory unfolding. As long as its -argument is not levity-polymorphic (which it can't be, according to -Note [Levity polymorphism invariants] in GHC.Core), and it's saturated, -no levity-polymorphic code ends up in the code generator. The saturation -condition is effectively checked by Note [Detecting forced eta expansion] -in GHC.HsToCore.Expr. - -However, if we make a *wrapper* for a newtype, we get into trouble. -The saturation condition is no longer checked (because hasNoBinding -returns False) and indeed we generate a forbidden levity-polymorphic -binding. - -The solution is simple, though: just make the newtype wrappers -as ephemeral as the newtype workers. In other words, give the wrappers -compulsory unfoldings and no bindings. The compulsory unfolding is given -in wrap_unf in mkDataConRep, and the lack of a binding happens in -GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no -implicit bindings. - -************************************************************************ -* * -\subsection{Dictionary selectors} -* * -************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -Dictionary selectors may get nested forall-types. Thus: - - class Foo a where - op :: forall b. Ord b => a -> b -> b - -Then the top-level type for op is - - op :: forall a. Foo a => - forall b. Ord b => - a -> b -> b - --} - -mkDictSelId :: Name -- Name of one of the *value* selectors - -- (dictionary superclass or method) - -> Class -> Id -mkDictSelId name clas - = mkGlobalId (ClassOpId clas) name sel_ty info - where - tycon = classTyCon clas - sel_names = map idName (classAllSelIds clas) - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUserTyVarBinders data_con - n_ty_args = length tyvars - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name - - sel_ty = mkForAllTys tyvars $ - mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ - getNth arg_tys val_index - - base_info = noCafIdInfo - `setArityInfo` 1 - `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig - `setLevityInfoWithType` sel_ty - - info | new_tycon - = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - (mkDictSelRhs clas val_index) - -- See Note [Single-method classes] in TcInstDcls - -- for why alwaysInlinePragma - - | otherwise - = base_info `setRuleInfo` mkRuleInfo [rule] - -- Add a magic BuiltinRule, but no unfolding - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in TcInstDcls - - -- This is the built-in rule that goes - -- op (dfT d1 d2) ---> opT d1 d2 - rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` - occNameFS (getOccName name) - , ru_fn = name - , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args } - - -- The strictness signature is of the form U(AAAVAAAA) -> T - -- where the V depends on which item we are selecting - -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined - - strict_sig = mkClosedStrictSig [arg_dmd] topDiv - arg_dmd | new_tycon = evalDmd - | otherwise = mkManyUsedDmd $ - mkProdDmd [ if name == sel_name then evalDmd else absDmd - | sel_name <- sel_names ] - -mkDictSelRhs :: Class - -> Int -- 0-indexed selector among (superclasses ++ methods) - -> CoreExpr -mkDictSelRhs clas val_index - = mkLams tyvars (Lam dict_id rhs_body) - where - tycon = classTyCon clas - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - - the_arg_id = getNth arg_ids val_index - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 pred - arg_ids = mkTemplateLocalsNum 2 arg_tys - - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) - (Var dict_id) - | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) - arg_ids (varToCoreExpr the_arg_id) - -- varToCoreExpr needed for equality superclass selectors - -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } - -dictSelRule :: Int -> Arity -> RuleFun --- Tries to persuade the argument to look like a constructor --- application, using exprIsConApp_maybe, and then selects --- from it --- sel_i t1..tk (D t1..tk op1 ... opm) = opi --- -dictSelRule val_index n_ty_args _ id_unf _ args - | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - = Just (wrapFloats floats $ getNth con_args val_index) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Data constructors -* * -************************************************************************ --} - -mkDataConWorkId :: Name -> DataCon -> Id -mkDataConWorkId wkr_name data_con - | isNewTyCon tycon - = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info - -- See Note [Newtype workers] - - | otherwise - = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info - - where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con - - ----------- Workers for data types -------------- - alg_wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setStrictnessInfo` wkr_sig - `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, - -- even if arity = 0 - `setLevityInfoWithType` wkr_ty - -- NB: unboxed tuples have workers, so we can't use - -- setNeverLevPoly - - wkr_arity = dataConRepArity data_con - wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv - -- Note [Data-con worker strictness] - -- Notice that we do *not* say the worker Id is strict - -- even if the data constructor is declared strict - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has - -- case expressions that do the evals) but the *worker* MkT itself is - -- not. If we pretend it is strict then when we see - -- case x of y -> MkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- the worker MkT is strict) and drops the case. No, the workerId - -- MkT is not strict. - -- - -- However, the worker does have StrictnessMarks. When the simplifier - -- sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys - nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` 1 -- Arity 1 - `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` newtype_unf - `setLevityInfoWithType` wkr_ty - id_arg1 = mkTemplateLocal 1 (head arg_tys) - res_ty_args = mkTyCoVarTys univ_tvs - newtype_unf = ASSERT2( isVanillaDataCon data_con && - isSingleton arg_tys - , ppr data_con ) - -- Note [Newtype datacons] - mkCompulsoryUnfolding $ - mkLams univ_tvs $ Lam id_arg1 $ - wrapNewTypeBody tycon res_ty_args (Var id_arg1) - -dataConCPR :: DataCon -> CprResult -dataConCPR con - | isDataTyCon tycon -- Real data types only; that is, - -- not unboxed tuples or newtypes - , null (dataConExTyCoVars con) -- No existentials - , wkr_arity > 0 - , wkr_arity <= mAX_CPR_SIZE - = conCpr (dataConTag con) - | otherwise - = topCpr - where - tycon = dataConTyCon con - wkr_arity = dataConRepArity con - - mAX_CPR_SIZE :: Arity - mAX_CPR_SIZE = 10 - -- We do not treat very big tuples as CPR-ish: - -- a) for a start we get into trouble because there aren't - -- "enough" unboxed tuple types (a tiresome restriction, - -- but hard to fix), - -- b) more importantly, big unboxed tuples get returned mainly - -- on the stack, and are often then allocated in the heap - -- by the caller. So doing CPR for them may in fact make - -- things worse. - -{- -------------------------------------------------- --- Data constructor representation --- --- This is where we decide how to wrap/unwrap the --- constructor fields --- --------------------------------------------------- --} - -type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) - -- Unbox: bind rep vars by decomposing src var - -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) - -- Box: build src arg using these rep vars - --- | Data Constructor Boxer -newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) - -- Bind these src-level vars, returning the - -- rep-level vars to bind in the pattern - -vanillaDataConBoxer :: DataConBoxer --- No transformation on arguments needed -vanillaDataConBoxer = DCB (\_tys args -> return (args, [])) - -{- -Note [Inline partially-applied constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We allow the wrapper to inline when partially applied to avoid -boxing values unnecessarily. For example, consider - - data Foo a = Foo !Int a - - instance Traversable Foo where - traverse f (Foo i a) = Foo i <$> f a - -This desugars to - - traverse f foo = case foo of - Foo i# a -> let i = I# i# - in map ($WFoo i) (f a) - -If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. -But if we inline the wrapper, we get - - map (\a. case i of I# i# a -> Foo i# a) (f a) - -and now case-of-known-constructor eliminates the redundant allocation. - --} - -mkDataConRep :: DynFlags - -> FamInstEnvs - -> Name - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] - -> DataCon - -> UniqSM DataConRep -mkDataConRep dflags fam_envs wrap_name mb_bangs data_con - | not wrapper_reqd - = return NoDataConRep - - | otherwise - = do { wrap_args <- mapM newLocal wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) - initial_wrap_app - - ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info - wrap_info = noCafIdInfo - `setArityInfo` wrap_arity - -- It's important to specify the arity, so that partial - -- applications are treated as values - `setInlinePragInfo` wrap_prag - `setUnfoldingInfo` wrap_unf - `setStrictnessInfo` wrap_sig - `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) - -- We need to get the CAF info right here because GHC.Iface.Tidy - -- does not tidy the IdInfo of implicit bindings (like the wrapper) - -- so it not make sure that the CAF info is sane - `setLevityInfoWithType` wrap_ty - - wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv - - wrap_arg_dmds = - replicate (length theta) topDmd ++ map mk_dmd arg_ibangs - -- Don't forget the dictionary arguments when building - -- the strictness signature (#14290). - - mk_dmd str | isBanged str = evalDmd - | otherwise = topDmd - - wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` - activeDuringFinal - -- See Note [Activation for data constructor wrappers] - - -- The wrapper will usually be inlined (see wrap_unf), so its - -- strictness and CPR info is usually irrelevant. But this is - -- not always the case; GHC may choose not to inline it. In - -- particular, the wrapper constructor is not inlined inside - -- an INLINE rhs or when it is not applied to any arguments. - -- See Note [Inline partially-applied constructor wrappers] - -- Passing Nothing here allows the wrapper to inline when - -- unsaturated. - wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs - -- See Note [Compulsory newtype unfolding] - | otherwise = mkInlineUnfolding wrap_rhs - wrap_rhs = mkLams wrap_tvs $ - mkLams wrap_args $ - wrapFamInstBody tycon res_ty_args $ - wrap_body - - ; return (DCR { dcr_wrap_id = wrap_id - , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } - - where - (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) - = dataConFullSig data_con - wrap_tvs = dataConUserTyVars data_con - res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs - - tycon = dataConTyCon data_con -- The representation TyCon (not family) - wrap_ty = dataConUserType data_con - ev_tys = eqSpecPreds eq_spec ++ theta - all_arg_tys = ev_tys ++ orig_arg_tys - ev_ibangs = map (const HsLazy) ev_tys - orig_bangs = dataConSrcBangs data_con - - wrap_arg_tys = theta ++ orig_arg_tys - wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys - -- The wrap_args are the arguments *other than* the eq_spec - -- Because we are going to apply the eq_spec args manually in the - -- wrapper - - new_tycon = isNewTyCon tycon - arg_ibangs - | new_tycon - = ASSERT( isSingleton orig_arg_tys ) - [HsLazy] -- See Note [HsImplBangs for newtypes] - | otherwise - = case mb_bangs of - Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) - orig_arg_tys orig_bangs - Just bangs -> bangs - - (rep_tys_w_strs, wrappers) - = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) - - (unboxers, boxers) = unzip wrappers - (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) - - wrapper_reqd = - (not new_tycon - -- (Most) newtypes have only a worker, with the exception - -- of some newtypes written with GADT syntax. See below. - && (any isBanged (ev_ibangs ++ arg_ibangs) - -- Some forcing/unboxing (includes eq_spec) - || (not $ null eq_spec))) -- GADT - || isFamInstTyCon tycon -- Cast result - || dataConUserTyVarsArePermuted data_con - -- If the data type was written with GADT syntax and - -- orders the type variables differently from what the - -- worker expects, it needs a data con wrapper to reorder - -- the type variables. - -- See Note [Data con wrappers and GADT syntax]. - - initial_wrap_app = Var (dataConWorkId data_con) - `mkTyApps` res_ty_args - `mkVarApps` ex_tvs - `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec - - mk_boxer :: [Boxer] -> DataConBoxer - mk_boxer boxers = DCB (\ ty_args src_vars -> - do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars - subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTCvSubstList subst1 ex_tvs - (mkTyCoVarTys ex_vars) - ; (rep_ids, binds) <- go subst2 boxers term_vars - ; return (ex_vars ++ rep_ids, binds) } ) - - go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) - go subst (UnitBox : boxers) (src_var : src_vars) - = do { (rep_ids2, binds) <- go subst boxers src_vars - ; return (src_var : rep_ids2, binds) } - go subst (Boxer boxer : boxers) (src_var : src_vars) - = do { (rep_ids1, arg) <- boxer subst - ; (rep_ids2, binds) <- go subst boxers src_vars - ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } - go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) - - mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr - mk_rep_app [] con_app - = return con_app - mk_rep_app ((wrap_arg, unboxer) : prs) con_app - = do { (rep_ids, unbox_fn) <- unboxer wrap_arg - ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) - ; return (unbox_fn expr) } - -{- Note [Activation for data constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Activation on a data constructor wrapper allows it to inline only in Phase -0. This way rules have a chance to fire if they mention a data constructor on -the left - RULE "foo" f (K a b) = ... -Since the LHS of rules are simplified with InitialPhase, we won't -inline the wrapper on the LHS either. - -On the other hand, this means that exprIsConApp_maybe must be able to deal -with wrappers so that case-of-constructor is not delayed; see -Note [exprIsConApp_maybe on data constructors with wrappers] for details. - -It used to activate in phases 2 (afterInitial) and later, but it makes it -awkward to write a RULE[1] with a constructor on the left: it would work if a -constructor has no wrapper, but whether a constructor has a wrapper depends, for -instance, on the order of type argument of that constructors. Therefore changing -the order of type argument could make previously working RULEs fail. - -See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . - - -Note [Bangs on imported data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs -from imported modules. - -- Nothing <=> use HsSrcBangs -- Just bangs <=> use HsImplBangs - -For imported types we can't work it all out from the HsSrcBangs, -because we want to be very sure to follow what the original module -(where the data type was declared) decided, and that depends on what -flags were enabled when it was compiled. So we record the decisions in -the interface file. - -The HsImplBangs passed are in 1-1 correspondence with the -dataConOrigArgTys of the DataCon. - -Note [Data con wrappers and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Int# - -We certainly do not want to make a wrapper - $WMkT x = case x of y { DEFAULT -> MkT y } - -For a start, it's still to generate a no-op. But worse, since wrappers -are currently injected at TidyCore, we don't even optimise it away! -So the stupid case expression stays there. This actually happened for -the Integer data type (see #1600 comment:66)! - -Note [Data con wrappers and GADT syntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these two very similar data types: - - data T1 a b = MkT1 b - - data T2 a b where - MkT2 :: forall b a. b -> T2 a b - -Despite their similar appearance, T2 will have a data con wrapper but T1 will -not. What sets them apart? The types of their constructors, which are: - - MkT1 :: forall a b. b -> T1 a b - MkT2 :: forall b a. b -> T2 a b - -MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` -would normally appear. See Note [DataCon user type variable binders] in DataCon -for further discussion on this topic. - -The worker data cons for T1 and T2, however, both have types such that `a` is -expected to come before `b` as arguments. Because MkT2 permutes this order, it -needs a data con wrapper to swizzle around the type variables to be in the -order the worker expects. - -A somewhat surprising consequence of this is that *newtypes* can have data con -wrappers! After all, a newtype can also be written with GADT syntax: - - newtype T3 a b where - MkT3 :: forall b a. b -> T3 a b - -Again, this needs a wrapper data con to reorder the type variables. It does -mean that this newtype constructor requires another level of indirection when -being called, but the inliner should make swift work of that. - -Note [HsImplBangs for newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the time, we use the dataConSrctoImplBang function to decide what -strictness/unpackedness to use for the fields of a data type constructor. But -there is an exception to this rule: newtype constructors. You might not think -that newtypes would pose a challenge, since newtypes are seemingly forbidden -from having strictness annotations in the first place. But consider this -(from #16141): - - {-# LANGUAGE StrictData #-} - {-# OPTIONS_GHC -O #-} - newtype T a b where - MkT :: forall b a. Int -> T a b - -Because StrictData (plus optimization) is enabled, invoking -dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! -This would be disastrous, since the wrapper for `MkT` uses a coercion involving -Int, not Int#. - -Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the -case of a newtype constructor, we simply hardcode its dcr_bangs field to -[HsLazy]. --} - -------------------------- -newLocal :: Type -> UniqSM Var -newLocal ty = do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } - -- We should not have "OrCoVar" here, this is a bug (#17545) - - --- | Unpack/Strictness decisions from source module. --- --- This function should only ever be invoked for data constructor fields, and --- never on the field of a newtype constructor. --- See @Note [HsImplBangs for newtypes]@. -dataConSrcToImplBang - :: DynFlags - -> FamInstEnvs - -> Type - -> HsSrcBang - -> HsImplBang - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk NoSrcStrict) - | xopt LangExt.StrictData dflags -- StrictData => strict field - = dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk SrcStrict) - | otherwise -- no StrictData => lazy field - = HsLazy - -dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) - = HsLazy - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang _ unpk_prag SrcStrict) - | isUnliftedType arg_ty - = HsLazy -- For !Int#, say, use HsLazy - -- See Note [Data con wrappers and unlifted types] - - | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas - -- Don't unpack if we aren't optimising; rather arbitrarily, - -- we use -fomit-iface-pragmas as the indication - , let mb_co = topNormaliseType_maybe fam_envs arg_ty - -- Unwrap type families and newtypes - arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } - , isUnpackableType dflags fam_envs arg_ty' - , (rep_tys, _) <- dataConArgUnpack arg_ty' - , case unpk_prag of - NoSrcUnpack -> - gopt Opt_UnboxStrictFields dflags - || (gopt Opt_UnboxSmallStrictFields dflags - && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] - srcUnpack -> isSrcUnpacked srcUnpack - = case mb_co of - Nothing -> HsUnpack Nothing - Just (co,_) -> HsUnpack (Just co) - - | otherwise -- Record the strict-but-no-unpack decision - = HsStrict - - --- | Wrappers/Workers and representation following Unpack/Strictness --- decisions -dataConArgRep - :: Type - -> HsImplBang - -> ([(Type,StrictnessMark)] -- Rep types - ,(Unboxer,Boxer)) - -dataConArgRep arg_ty HsLazy - = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) - -dataConArgRep arg_ty HsStrict - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) - -dataConArgRep arg_ty (HsUnpack Nothing) - | (rep_tys, wrappers) <- dataConArgUnpack arg_ty - = (rep_tys, wrappers) - -dataConArgRep _ (HsUnpack (Just co)) - | let co_rep_ty = coercionRKind co - , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty - = (rep_tys, wrapCo co co_rep_ty wrappers) - - -------------------------- -wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) -wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty - = (unboxer, boxer) - where - unboxer arg_id = do { rep_id <- newLocal rep_ty - ; (rep_ids, rep_fn) <- unbox_rep rep_id - ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) - ; return (rep_ids, Let co_bind . rep_fn) } - boxer = Boxer $ \ subst -> - do { (rep_ids, rep_expr) - <- case box_rep of - UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) - ; return ([rep_id], Var rep_id) } - Boxer boxer -> boxer subst - ; let sco = substCoUnchecked subst co - ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } - ------------------------- -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - -unitUnboxer :: Unboxer -unitUnboxer v = return ([v], \e -> e) - -unitBoxer :: Boxer -unitBoxer = UnitBox - -------------------------- -dataConArgUnpack - :: Type - -> ( [(Type, StrictnessMark)] -- Rep types - , (Unboxer, Boxer) ) - -dataConArgUnpack arg_ty - | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty - , Just con <- tyConSingleAlgDataCon_maybe tc - -- NB: check for an *algebraic* data type - -- A recursive newtype might mean that - -- 'arg_ty' is a newtype - , let rep_tys = dataConInstArgTys con tc_args - = ASSERT( null (dataConExTyCoVars con) ) - -- Note [Unpacking GADTs and existentials] - ( rep_tys `zip` dataConRepStrictness con - ,( \ arg_id -> - do { rep_ids <- mapM newLocal rep_tys - ; let unbox_fn body - = mkSingleAltCase (Var arg_id) arg_id - (DataAlt con) rep_ids body - ; return (rep_ids, unbox_fn) } - , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys - ; return (rep_ids, Var (dataConWorkId con) - `mkTyApps` (substTysUnchecked subst tc_args) - `mkVarApps` rep_ids ) } ) ) - | otherwise - = pprPanic "dataConArgUnpack" (ppr arg_ty) - -- An interface file specified Unpacked, but we couldn't unpack it - -isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool --- True if we can unpack the UNPACK the argument type --- See Note [Recursive unboxing] --- We look "deeply" inside rather than relying on the DataCons --- we encounter on the way, because otherwise we might well --- end up relying on ourselves! -isUnpackableType dflags fam_envs ty - | Just data_con <- unpackable_type ty - = ok_con_args emptyNameSet data_con - | otherwise - = False - where - ok_con_args dcs con - | dc_name `elemNameSet` dcs - = False - | otherwise - = all (ok_arg dcs') - (dataConOrigArgTys con `zip` dataConSrcBangs con) - -- NB: dataConSrcBangs gives the *user* request; - -- We'd get a black hole if we used dataConImplBangs - where - dc_name = getName con - dcs' = dcs `extendNameSet` dc_name - - ok_arg dcs (ty, bang) - = not (attempt_unpack bang) || ok_ty dcs norm_ty - where - norm_ty = topNormaliseType fam_envs ty - - ok_ty dcs ty - | Just data_con <- unpackable_type ty - = ok_con_args dcs data_con - | otherwise - = True -- NB True here, in contrast to False at top level - - attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags - attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) - = True - attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) - = True -- Be conservative - attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags -- Be conservative - attempt_unpack _ = False - - unpackable_type :: Type -> Maybe DataCon - -- Works just on a single level - unpackable_type ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just data_con <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyCoVars data_con) - -- See Note [Unpacking GADTs and existentials] - = Just data_con - | otherwise - = Nothing - -{- -Note [Unpacking GADTs and existentials] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is nothing stopping us unpacking a data type with equality -components, like - data Equal a b where - Equal :: Equal a a - -And it'd be fine to unpack a product type with existential components -too, but that would require a bit more plumbing, so currently we don't. - -So for now we require: null (dataConExTyCoVars data_con) -See #14978 - -Note [Unpack one-wide fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flag UnboxSmallStrictFields ensures that any field that can -(safely) be unboxed to a word-sized unboxed field, should be so unboxed. -For example: - - data A = A Int# - newtype B = B A - data C = C !B - data D = D !C - data E = E !() - data F = F !D - data G = G !F !F - -All of these should have an Int# as their representation, except -G which should have two Int#s. - -However - - data T = T !(S Int) - data S = S !a - -Here we can represent T with an Int#. - -Note [Recursive unboxing] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data R = MkR {-# UNPACK #-} !S Int - data S = MkS {-# UNPACK #-} !Int -The representation arguments of MkR are the *representation* arguments -of S (plus Int); the rep args of MkS are Int#. This is all fine. - -But be careful not to try to unbox this! - data T = MkT {-# UNPACK #-} !T Int -Because then we'd get an infinite number of arguments. - -Here is a more complicated case: - data S = MkS {-# UNPACK #-} !T Int - data T = MkT {-# UNPACK #-} !S Int -Each of S and T must decide independently whether to unpack -and they had better not both say yes. So they must both say no. - -Also behave conservatively when there is no UNPACK pragma - data T = MkS !T Int -with -funbox-strict-fields or -funbox-small-strict-fields -we need to behave as if there was an UNPACK pragma there. - -But it's the *argument* type that matters. This is fine: - data S = MkS S !Int -because Int is non-recursive. - -************************************************************************ -* * - Wrapping and unwrapping newtypes and type families -* * -************************************************************************ --} - -wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr --- The wrapper for the data constructor for a newtype looks like this: --- newtype T a = MkT (a,Int) --- MkT :: forall a. (a,Int) -> T a --- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) --- where CoT is the coercion TyCon associated with the newtype --- --- The call (wrapNewTypeBody T [a] e) returns the --- body of the wrapper, namely --- e `cast` (CoT [a]) --- --- If a coercion constructor is provided in the newtype, then we use --- it, otherwise the wrap/unwrap are both no-ops - -wrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkSymCo co) - where - co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] - --- When unwrapping, we do *not* apply any family coercion, because this will --- be done via a CoPat by the type checker. We have to do it this way as --- computing the right type arguments for the coercion requires more than just --- a splitting operation (cf, TcPat.tcConPat). - -unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) - --- If the type constructor is a representation type of a data instance, wrap --- the expression into a cast adjusting the expression type, which is an --- instance of the representation type, to the corresponding instance of the --- family instance type. --- See Note [Wrappers for data instance tycons] -wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -wrapFamInstBody tycon args body - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) - | otherwise - = body - -{- -************************************************************************ -* * -\subsection{Primitive operations} -* * -************************************************************************ --} - -mkPrimOpId :: PrimOp -> Id -mkPrimOpId prim_op - = id - where - (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) - name = mkWiredInName gHC_PRIM (primOpOcc prim_op) - (mkPrimOpIdUnique (primOpTag prim_op)) - (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info - - -- PrimOps don't ever construct a product, but we want to preserve bottoms - cpr - | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr - | otherwise = topCpr - - info = noCafIdInfo - `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setCprInfo` mkCprSig arity cpr - `setInlinePragInfo` neverInlinePragma - `setLevityInfoWithType` res_ty - -- We give PrimOps a NOINLINE pragma so that we don't - -- get silly warnings from Desugar.dsRule (the inline_shadows_rule - -- test) about a RULE conflicting with a possible inlining - -- cf #7287 - --- For each ccall we manufacture a separate CCallOpId, giving it --- a fresh unique, a type that is correct for this particular ccall, --- and a CCall structure that gives the correct details about calling --- convention etc. --- --- The *name* of this Id is a local name whose OccName gives the full --- details of the ccall, type and all. This means that the interface --- file reader can reconstruct a suitable Id - -mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id -mkFCallId dflags uniq fcall ty - = ASSERT( noFreeVarsOfType ty ) - -- A CCallOpId should have no free type variables; - -- when doing substitutions won't substitute over it - mkGlobalId (FCallId fcall) name ty info - where - occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) - -- The "occurrence name" of a ccall is the full info about the - -- ccall; it is encoded, but may have embedded spaces etc! - - name = mkFCallName uniq occ_str - - info = noCafIdInfo - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig - `setLevityInfoWithType` ty - - (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv - -- the call does not claim to be strict in its arguments, since they - -- may be lifted (foreign import prim) and the called code doesn't - -- necessarily force them. See #11076. -{- -************************************************************************ -* * -\subsection{DictFuns and default methods} -* * -************************************************************************ - -Note [Dict funs and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dict funs and default methods are *not* ImplicitIds. Their definition -involves user-written code, so we can't figure out their strictness etc -based on fixed info, as we can for constructors and record selectors (say). - -NB: See also Note [Exported LocalIds] in Id --} - -mkDictFunId :: Name -- Name to use for the dict fun; - -> [TyVar] - -> ThetaType - -> Class - -> [Type] - -> Id --- Implements the DFun Superclass Invariant (see TcInstDcls) --- See Note [Dict funs and default methods] - -mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalId (DFunId is_nt) - dfun_name - dfun_ty - where - is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys - -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type -mkDictFunTy tvs theta clas tys - = mkSpecSigmaTy tvs theta (mkClassPred clas tys) - -{- -************************************************************************ -* * -\subsection{Un-definable} -* * -************************************************************************ - -These Ids can't be defined in Haskell. They could be defined in -unfoldings in the wired-in GHC.Prim interface file, but we'd have to -ensure that they were definitely, definitely inlined, because there is -no curried identifier for them. That's what mkCompulsoryUnfolding -does. If we had a way to get a compulsory unfolding from an interface -file, we could do that, but we don't right now. - -The type variables we use here are "open" type variables: this means -they can unify with both unlifted and lifted types. Hence we provide -another gun with which to shoot yourself in the foot. --} - -nullAddrName, seqName, - realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName :: Name -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId -coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId -magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId -coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId -proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId - -lazyIdName, oneShotName, noinlineIdName :: Name -lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId -oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId - ------------------------------------------------- -proxyHashId :: Id -proxyHashId - = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` ty ) - where - -- proxy# :: forall {k} (a:k). Proxy# k a - -- - -- The visibility of the `k` binder is Inferred to match the type of the - -- Proxy data constructor (#16293). - [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id - kv_ty = mkTyVarTy kv - tv_ty = mkTyVarTy tv - ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty - ------------------------------------------------- -nullAddrId :: Id --- nullAddr# :: Addr# --- The reason it is here is because we don't provide --- a way to write this literal in Haskell. -nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) - `setNeverLevPoly` addrPrimTy - ------------------------------------------------- -seqId :: Id -- See Note [seqId magic] -seqId = pcMiscPrelId seqName ty info - where - info = noCafIdInfo `setInlinePragInfo` inline_prag - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - inline_prag - = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter - NoSourceText 0 - -- Make 'seq' not inline-always, so that simpleOptExpr - -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the - -- LHS of rules. That way we can have rules for 'seq'; - -- see Note [seqId magic] - - -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b - ty = - mkInvForAllTy runtimeRep2TyVar - $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] - $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) - - [x,y] = mkTemplateLocals [alphaTy, openBetaTy] - rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ - Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] - ------------------------------------------------- -lazyId :: Id -- See Note [lazyId magic] -lazyId = pcMiscPrelId lazyIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) - -noinlineId :: Id -- See Note [noinlineId magic] -noinlineId = pcMiscPrelId noinlineIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) - -oneShotId :: Id -- See Note [The oneShot function] -oneShotId = pcMiscPrelId oneShotName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] - (mkVisFunTy fun_ty fun_ty) - fun_ty = mkVisFunTy openAlphaTy openBetaTy - [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] - x' = setOneShotLambda x -- Here is the magic bit! - rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar - , body, x'] $ - Var body `App` Var x - --------------------------------------------------------------------------------- -magicDictId :: Id -- See Note [magicDictId magic] -magicDictId = pcMiscPrelId magicDictName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] alphaTy - --------------------------------------------------------------------------------- - -coerceId :: Id -coerceId = pcMiscPrelId coerceName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] - ty = mkForAllTys [ Bndr rv Inferred - , Bndr av Specified - , Bndr bv Specified - ] $ - mkInvisFunTy eqRTy $ - mkVisFunTy a b - - bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy - (\r -> [tYPE r, tYPE r]) - - [r, a, b] = mkTyVarTys bndrs - - [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] - rhs = mkLams (bndrs ++ [eqR, x]) $ - mkWildCase (Var eqR) eqRTy b $ - [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] - -{- -Note [seqId magic] -~~~~~~~~~~~~~~~~~~ -'GHC.Prim.seq' is special in several ways. - -a) Its fixity is set in GHC.Iface.Load.ghcPrimIface - -b) It has quite a bit of desugaring magic. - See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3) - -c) There is some special rule handing: Note [User-defined RULES for seq] - -Historical note: - In TcExpr we used to need a special typing rule for 'seq', to handle calls - whose second argument had an unboxed type, e.g. x `seq` 3# - - However, with levity polymorphism we can now give seq the type seq :: - forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this - case without special treatment in the typechecker. - -Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Roman found situations where he had - case (f n) of _ -> e -where he knew that f (which was strict in n) would terminate if n did. -Notice that the result of (f n) is discarded. So it makes sense to -transform to - case n of _ -> e - -Rather than attempt some general analysis to support this, I've added -enough support that you can do this using a rewrite rule: - - RULE "f/seq" forall n. seq (f n) = seq n - -You write that rule. When GHC sees a case expression that discards -its result, it mentally transforms it to a call to 'seq' and looks for -a RULE. (This is done in Simplify.trySeqRules.) As usual, the -correctness of the rule is up to you. - -VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. -If we wrote - RULE "f/seq" forall n e. seq (f n) e = seq n e -with rule arity 2, then two bad things would happen: - - - The magical desugaring done in Note [seqId magic] item (b) - for saturated application of 'seq' would turn the LHS into - a case expression! - - - The code in Simplify.rebuildCase would need to actually supply - the value argument, which turns out to be awkward. - -See also: Note [User-defined RULES for seq] in Simplify. - - -Note [lazyId magic] -~~~~~~~~~~~~~~~~~~~ -lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) - -'lazy' is used to make sure that a sub-expression, and its free variables, -are truly used call-by-need, with no code motion. Key examples: - -* pseq: pseq a b = a `seq` lazy b - We want to make sure that the free vars of 'b' are not evaluated - before 'a', even though the expression is plainly strict in 'b'. - -* catch: catch a b = catch# (lazy a) b - Again, it's clear that 'a' will be evaluated strictly (and indeed - applied to a state token) but we want to make sure that any exceptions - arising from the evaluation of 'a' are caught by the catch (see - #11555). - -Implementing 'lazy' is a bit tricky: - -* It must not have a strictness signature: by being a built-in Id, - all the info about lazyId comes from here, not from GHC.Base.hi. - This is important, because the strictness analyser will spot it as - strict! - -* It must not have an unfolding: it gets "inlined" by a HACK in - CorePrep. It's very important to do this inlining *after* unfoldings - are exposed in the interface file. Otherwise, the unfolding for - (say) pseq in the interface file will not mention 'lazy', so if we - inline 'pseq' we'll totally miss the very thing that 'lazy' was - there for in the first place. See #3259 for a real world - example. - -* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must - avoid using call by value here: - case e of r -> catch# r b - Avoiding that is the whole point of 'lazy'. So in CorePrep (which - generate the 'case' expression for a call-by-value call) we must - spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' - instead. - -* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it - appears un-applied, we'll end up just calling it. - -Note [noinlineId magic] -~~~~~~~~~~~~~~~~~~~~~~~ -noinline :: forall a. a -> a - -'noinline' is used to make sure that a function f is never inlined, -e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE -could be used to achieve this effect; however, this has the unfortunate -result of leaving a (useless) call to noinline at runtime. So we have -a little bit of magic to optimize away 'noinline' after we are done -running the simplifier. - -'noinline' needs to be wired-in because it gets inserted automatically -when we serialize an expression to the interface format. See -Note [Inlining and hs-boot files] in GHC.CoreToIface - -Note that noinline as currently implemented can hide some simplifications since -it hides strictness from the demand analyser. Specifically, the demand analyser -will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' -specifies that it is strict in its argument. We considered fixing this this by adding a -special case to the demand analyser to address #16588. However, the special -case seemed like a large and expensive hammer to address a rare case and -consequently we rather opted to use a more minimal solution. - -Note [The oneShot function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the context of making left-folds fuse somewhat okish (see ticket #7994 -and Note [Left folds via right fold]) it was determined that it would be useful -if library authors could explicitly tell the compiler that a certain lambda is -called at most once. The oneShot function allows that. - -'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted -types as well (#10744); e.g. - oneShot (\x:Int# -> x +# 1#) - -Like most magic functions it has a compulsory unfolding, so there is no need -for a real definition somewhere. We have one in GHC.Magic for the convenience -of putting the documentation there. - -It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: - -A typical call looks like - oneShot (\y. e) -after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get - (\f \x[oneshot]. f x) (\y. e) - --> \x[oneshot]. ((\y.e) x) - --> \x[oneshot] e[x/y] -which is what we want. - -It is only effective if the one-shot info survives as long as possible; in -particular it must make it into the interface in unfoldings. See Note [Preserve -OneShotInfo] in GHC.Core.Op.Tidy. - -Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. - - -Note [magicDictId magic] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The identifier `magicDict` is just a place-holder, which is used to -implement a primitive that we cannot define in Haskell but we can write -in Core. It is declared with a place-holder type: - - magicDict :: forall a. a - -The intention is that the identifier will be used in a very specific way, -to create dictionaries for classes with a single method. Consider a class -like this: - - class C a where - f :: T a - -We are going to use `magicDict`, in conjunction with a built-in Prelude -rule, to cast values of type `T a` into dictionaries for `C a`. To do -this, we define a function like this in the library: - - data WrapC a b = WrapC (C a => Proxy a -> b) - - withT :: (C a => Proxy a -> b) - -> T a -> Proxy a -> b - withT f x y = magicDict (WrapC f) x y - -The purpose of `WrapC` is to avoid having `f` instantiated. -Also, it avoids impredicativity, because `magicDict`'s type -cannot be instantiated with a forall. The field of `WrapC` contains -a `Proxy` parameter which is used to link the type of the constraint, -`C a`, with the type of the `Wrap` value being made. - -Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), -which will replace the RHS of this definition with the appropriate -definition in Core. The rewrite rule works as follows: - - magicDict @t (wrap @a @b f) x y -----> - f (x `cast` co a) y - -The `co` coercion is the newtype-coercion extracted from the type-class. -The type class is obtain by looking at the type of wrap. - - -------------------------------------------------------------- -@realWorld#@ used to be a magic literal, \tr{void#}. If things get -nasty as-is, change it back to a literal (@Literal@). - -voidArgId is a Local Id used simply as an argument in functions -where we just want an arg to avoid having a thunk of unlifted type. -E.g. - x = \ void :: Void# -> (# p, q #) - -This comes up in strictness analysis - -Note [evaldUnfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The evaldUnfolding makes it look that some primitive value is -evaluated, which in turn makes Simplify.interestingArg return True, -which in turn makes INLINE things applied to said value likely to be -inlined. --} - -realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverLevPoly` realWorldStatePrimTy) - -voidPrimId :: Id -- Global constant :: Void# -voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` voidPrimTy) - -voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy - -coercionTokenId :: Id -- :: () ~ () -coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs - = pcMiscPrelId coercionTokenName - (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) - noCafIdInfo - -pcMiscPrelId :: Name -> Type -> IdInfo -> Id -pcMiscPrelId name ty info - = mkVanillaGlobalWithInfo name ty info - -- We lie and say the thing is imported; otherwise, we get into - -- a mess with dependency analysis; e.g., core2stg may heave in - -- random calls to GHCbase.unpackPS__. If GHCbase is the module - -- being compiled, then it's just a matter of luck if the definition - -- will be in "the right place" to be in scope. diff --git a/compiler/basicTypes/MkId.hs-boot b/compiler/basicTypes/MkId.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/MkId.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module MkId where -import Name( Name ) -import Var( Id ) -import Class( Class ) -import {-# SOURCE #-} DataCon( DataCon ) -import {-# SOURCE #-} PrimOp( PrimOp ) - -data DataConBoxer - -mkDataConWorkId :: Name -> DataCon -> Id -mkDictSelId :: Name -> Class -> Id - -mkPrimOpId :: PrimOp -> Id - -magicDictId :: Id diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs deleted file mode 100644 --- a/compiler/basicTypes/Module.hs +++ /dev/null @@ -1,1303 +0,0 @@ -{- -(c) The University of Glasgow, 2004-2006 - - -Module -~~~~~~~~~~ -Simply the name of a module, represented as a FastString. -These are Uniquable, hence we can build Maps with Modules as -the keys. --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Module - ( - -- * The ModuleName type - ModuleName, - pprModuleName, - moduleNameFS, - moduleNameString, - moduleNameSlashes, moduleNameColons, - moduleStableString, - moduleFreeHoles, - moduleIsDefinite, - mkModuleName, - mkModuleNameFS, - stableModuleNameCmp, - - -- * The UnitId type - ComponentId(..), - UnitId(..), - unitIdFS, - unitIdKey, - IndefUnitId(..), - IndefModule(..), - indefUnitIdToUnitId, - indefModuleToModule, - InstalledUnitId(..), - toInstalledUnitId, - ShHoleSubst, - - unitIdIsDefinite, - unitIdString, - unitIdFreeHoles, - - newUnitId, - newIndefUnitId, - newSimpleUnitId, - hashUnitId, - fsToUnitId, - stringToUnitId, - stableUnitIdCmp, - - -- * HOLE renaming - renameHoleUnitId, - renameHoleModule, - renameHoleUnitId', - renameHoleModule', - - -- * Generalization - splitModuleInsts, - splitUnitIdInsts, - generalizeIndefUnitId, - generalizeIndefModule, - - -- * Parsers - parseModuleName, - parseUnitId, - parseComponentId, - parseModuleId, - parseModSubst, - - -- * Wired-in UnitIds - -- $wired_in_packages - primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - mainUnitId, - thisGhcUnitId, - isHoleModule, - interactiveUnitId, isInteractiveModule, - wiredInUnitIds, - - -- * The Module type - Module(Module), - moduleUnitId, moduleName, - pprModule, - mkModule, - mkHoleModule, - stableModuleCmp, - HasModule(..), - ContainsModule(..), - - -- * Installed unit ids and modules - InstalledModule(..), - InstalledModuleEnv, - installedModuleEq, - installedUnitIdEq, - installedUnitIdString, - fsToInstalledUnitId, - componentIdToInstalledUnitId, - stringToInstalledUnitId, - emptyInstalledModuleEnv, - lookupInstalledModuleEnv, - extendInstalledModuleEnv, - filterInstalledModuleEnv, - delInstalledModuleEnv, - DefUnitId(..), - - -- * The ModuleLocation type - ModLocation(..), - addBootSuffix, addBootSuffix_maybe, - addBootSuffixLocn, addBootSuffixLocnOut, - - -- * Module mappings - ModuleEnv, - elemModuleEnv, extendModuleEnv, extendModuleEnvList, - extendModuleEnvList_C, plusModuleEnv_C, - delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, - lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvKeys, moduleEnvElts, moduleEnvToList, - unitModuleEnv, isEmptyModuleEnv, - extendModuleEnvWith, filterModuleEnv, - - -- * ModuleName mappings - ModuleNameEnv, DModuleNameEnv, - - -- * Sets of Modules - ModuleSet, - emptyModuleSet, mkModuleSet, moduleSetElts, - extendModuleSet, extendModuleSetList, delModuleSet, - elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, - unitModuleSet - ) where - -import GhcPrelude - -import Outputable -import Unique -import UniqFM -import UniqDFM -import UniqDSet -import FastString -import Binary -import Util -import Data.List (sortBy, sort) -import Data.Ord -import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) -import Fingerprint - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS.Char8 -import Encoding - -import qualified Text.ParserCombinators.ReadP as Parse -import Text.ParserCombinators.ReadP (ReadP, (<++)) -import Data.Char (isAlphaNum) -import Control.DeepSeq -import Data.Coerce -import Data.Data -import Data.Function -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified FiniteMap as Map -import System.FilePath - -import {-# SOURCE #-} GHC.Driver.Session (DynFlags) -import {-# SOURCE #-} GHC.Driver.Packages (componentIdString, improveUnitId, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId) - --- Note [The identifier lexicon] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Unit IDs, installed package IDs, ABI hashes, package names, --- versions, there are a *lot* of different identifiers for closely --- related things. What do they all mean? Here's what. (See also --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) --- --- THE IMPORTANT ONES --- --- ComponentId: An opaque identifier provided by Cabal, which should --- uniquely identify such things as the package name, the package --- version, the name of the component, the hash of the source code --- tarball, the selected Cabal flags, GHC flags, direct dependencies of --- the component. These are very similar to InstalledPackageId, but --- an 'InstalledPackageId' implies that it identifies a package, while --- a package may install multiple components with different --- 'ComponentId's. --- - Same as Distribution.Package.ComponentId --- --- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names --- (ModuleName) to Modules. This is how the compiler identifies instantiated --- components, and also is the main identifier by which GHC identifies things. --- - When Backpack is not being used, UnitId = ComponentId. --- this means a useful fiction for end-users is that there are --- only ever ComponentIds, and some ComponentIds happen to have --- more information (UnitIds). --- - Same as Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - The same as PackageKey in GHC 7.10 (we renamed it because --- they don't necessarily identify packages anymore.) --- - Same as -this-package-key/-package-name flags --- - An InstalledUnitId corresponds to an actual package which --- we have installed on disk. It could be definite or indefinite, --- but if it's indefinite, it has nothing instantiated (we --- never install partially instantiated units.) --- --- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how --- the compiler identifies modules (e.g. a Name is a Module + OccName) --- - Same as Language.Haskell.TH.Syntax:Module --- --- THE LESS IMPORTANT ONES --- --- PackageName: The "name" field in a Cabal file, something like "lens". --- - Same as Distribution.Package.PackageName --- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - DIFFERENT FROM -package-name flag --- - DIFFERENT FROM the 'name' field in an installed package --- information. This field could more accurately be described --- as a munged package name: when it's for the main library --- it is the same as the package name, but if it's an internal --- library it's a munged combination of the package name and --- the component name. --- --- LEGACY ONES --- --- InstalledPackageId: This is what we used to call ComponentId. --- It's a still pretty useful concept for packages that have only --- one library; in that case the logical InstalledPackageId = --- ComponentId. Also, the Cabal nix-local-build continues to --- compute an InstalledPackageId which is then forcibly used --- for all components in a package. This means that if a dependency --- from one component in a package changes, the InstalledPackageId --- changes: you don't get as fine-grained dependency tracking, --- but it means your builds are hermetic. Eventually, Cabal will --- deal completely in components and we can get rid of this. --- --- PackageKey: This is what we used to call UnitId. We ditched --- "Package" from the name when we realized that you might want to --- assign different "PackageKeys" to components from the same package. --- (For a brief, non-released period of time, we also called these --- UnitKeys). - -{- -************************************************************************ -* * -\subsection{Module locations} -* * -************************************************************************ --} - --- | Module Location --- --- Where a module lives on the file system: the actual locations --- of the .hs, .hi and .o files, if we have them -data ModLocation - = ModLocation { - ml_hs_file :: Maybe FilePath, - -- The source file, if we have one. Package modules - -- probably don't have source files. - - ml_hi_file :: FilePath, - -- Where the .hi file is, whether or not it exists - -- yet. Always of form foo.hi, even if there is an - -- hi-boot file (we add the -boot suffix later) - - ml_obj_file :: FilePath, - -- Where the .o file is, whether or not it exists yet. - -- (might not exist either because the module hasn't - -- been compiled yet, or because it is part of a - -- package with a .a file) - ml_hie_file :: FilePath - } deriving Show - -instance Outputable ModLocation where - ppr = text . show - -{- -For a module in another package, the hs_file and obj_file -components of ModLocation are undefined. - -The locations specified by a ModLocation may or may not -correspond to actual files yet: for example, even if the object -file doesn't exist, the ModLocation still contains the path to -where the object file will reside if/when it is created. --} - -addBootSuffix :: FilePath -> FilePath --- ^ Add the @-boot@ suffix to .hs, .hi and .o files -addBootSuffix path = path ++ "-boot" - -addBootSuffix_maybe :: Bool -> FilePath -> FilePath --- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ -addBootSuffix_maybe is_boot path - | is_boot = addBootSuffix path - | otherwise = path - -addBootSuffixLocn :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all file paths associated with the module -addBootSuffixLocn locn - = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) - , ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } - -addBootSuffixLocnOut :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all output file paths associated with the --- module, not including the input file itself -addBootSuffixLocnOut locn - = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } - -{- -************************************************************************ -* * -\subsection{The name of a module} -* * -************************************************************************ --} - --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -instance BinaryStringRep ModuleName where - fromStringRep = mkModuleNameFS . mkFastStringByteString - toStringRep = bytesFS . moduleNameFS - -instance Data ModuleName where - -- don't traverse? - toConstr _ = abstractConstr "ModuleName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ModuleName" - -instance NFData ModuleName where - rnf x = x `seq` () - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - --- | Get a string representation of a 'Module' that's unique and stable --- across recompilations. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" -moduleStableString :: Module -> String -moduleStableString Module{..} = - "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- |Returns the string version of the module name, with dots replaced by slashes. --- -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- |Returns the string version of the module name, with dots replaced by colons. --- -moduleNameColons :: ModuleName -> String -moduleNameColons = dots_to_colons . moduleNameString - where dots_to_colons = map (\c -> if c == '.' then ':' else c) - -{- -************************************************************************ -* * -\subsection{A fully qualified module} -* * -************************************************************************ --} - --- | A Module is a pair of a 'UnitId' and a 'ModuleName'. --- --- Module variables (i.e. @@) which can be instantiated to a --- specific module at some later point in time are represented --- with 'moduleUnitId' set to 'holeUnitId' (this allows us to --- avoid having to make 'moduleUnitId' a partial operation.) --- -data Module = Module { - moduleUnitId :: !UnitId, -- pkg-1.0 - moduleName :: !ModuleName -- A.B.C - } - deriving (Eq, Ord) - --- | Calculate the free holes of a 'Module'. If this set is non-empty, --- this module was defined in an indefinite library that had required --- signatures. --- --- If a module has free holes, that means that substitutions can operate on it; --- if it has no free holes, substituting over a module has no effect. -moduleFreeHoles :: Module -> UniqDSet ModuleName -moduleFreeHoles m - | isHoleModule m = unitUniqDSet (moduleName m) - | otherwise = unitIdFreeHoles (moduleUnitId m) - --- | A 'Module' is definite if it has no free holes. -moduleIsDefinite :: Module -> Bool -moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles - --- | Create a module variable at some 'ModuleName'. --- See Note [Representation of module/name variables] -mkHoleModule :: ModuleName -> Module -mkHoleModule = mkModule holeUnitId - -instance Uniquable Module where - getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) - -instance Outputable Module where - ppr = pprModule - -instance Binary Module where - put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) - -instance Data Module where - -- don't traverse? - toConstr _ = abstractConstr "Module" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Module" - -instance NFData Module where - rnf x = x `seq` () - --- | This gives a stable ordering, as opposed to the Ord instance which --- gives an ordering based on the 'Unique's of the components, which may --- not be stable from run to run of the compiler. -stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitIdCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) - -mkModule :: UnitId -> ModuleName -> Module -mkModule = Module - -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc - where - doc sty - | codeStyle sty = - (if p == mainUnitId - then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_') - <> pprModuleName n - | qualModule sty mod = - if isHoleModule mod - then angleBrackets (pprModuleName n) - else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n - | otherwise = - pprModuleName n - -class ContainsModule t where - extractModule :: t -> Module - -class HasModule m where - getModule :: m Module - -instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where - fromDbModule (DbModule uid mod_name) = mkModule uid mod_name - fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name - fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts - fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) - -- GHC never writes to the database, so it's not needed - toDbModule = error "toDbModule: not implemented" - toDbUnitId = error "toDbUnitId: not implemented" - -{- -************************************************************************ -* * -\subsection{ComponentId} -* * -************************************************************************ --} - --- | A 'ComponentId' consists of the package name, package version, component --- ID, the transitive dependencies of the component, and other information to --- uniquely identify the source code and build configuration of a component. --- --- This used to be known as an 'InstalledPackageId', but a package can contain --- multiple components and a 'ComponentId' uniquely identifies a component --- within a package. When a package only has one component, the 'ComponentId' --- coincides with the 'InstalledPackageId' -newtype ComponentId = ComponentId FastString deriving (Eq, Ord) - -instance BinaryStringRep ComponentId where - fromStringRep = ComponentId . mkFastStringByteString - toStringRep (ComponentId s) = bytesFS s - -instance Uniquable ComponentId where - getUnique (ComponentId n) = getUnique n - -instance Outputable ComponentId where - ppr cid@(ComponentId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case componentIdString dflags cid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -{- -************************************************************************ -* * -\subsection{UnitId} -* * -************************************************************************ --} - --- | A unit identifier identifies a (possibly partially) instantiated --- library. It is primarily used as part of 'Module', which in turn --- is used in 'Name', which is used to give names to entities when --- typechecking. --- --- There are two possible forms for a 'UnitId'. It can be a --- 'DefiniteUnitId', in which case we just have a string that uniquely --- identifies some fully compiled, installed library we have on disk. --- However, when we are typechecking a library with missing holes, --- we may need to instantiate a library on the fly (in which case --- we don't have any on-disk representation.) In that case, you --- have an 'IndefiniteUnitId', which explicitly records the --- instantiation, so that we can substitute over it. -data UnitId - = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId - | DefiniteUnitId {-# UNPACK #-} !DefUnitId - -unitIdFS :: UnitId -> FastString -unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x -unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x - -unitIdKey :: UnitId -> Unique -unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x -unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x - --- | A unit identifier which identifies an indefinite --- library (with holes) that has been *on-the-fly* instantiated --- with a substitution 'indefUnitIdInsts'. In fact, an indefinite --- unit identifier could have no holes, but we haven't gotten --- around to compiling the actual library yet. --- --- An indefinite unit identifier pretty-prints to something like --- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the --- brackets enclose the module substitution). -data IndefUnitId - = IndefUnitId { - -- | A private, uniquely identifying representation of - -- a UnitId. This string is completely private to GHC - -- and is just used to get a unique; in particular, we don't use it for - -- symbols (indefinite libraries are not compiled). - indefUnitIdFS :: FastString, - -- | Cached unique of 'unitIdFS'. - indefUnitIdKey :: Unique, - -- | The component identity of the indefinite library that - -- is being instantiated. - indefUnitIdComponentId :: !ComponentId, - -- | The sorted (by 'ModuleName') instantiations of this library. - indefUnitIdInsts :: ![(ModuleName, Module)], - -- | A cache of the free module variables of 'unitIdInsts'. - -- This lets us efficiently tell if a 'UnitId' has been - -- fully instantiated (free module variables are empty) - -- and whether or not a substitution can have any effect. - indefUnitIdFreeHoles :: UniqDSet ModuleName - } - -instance Eq IndefUnitId where - u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 - -instance Ord IndefUnitId where - u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 - -instance Binary IndefUnitId where - put_ bh indef = do - put_ bh (indefUnitIdComponentId indef) - put_ bh (indefUnitIdInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = hashUnitId cid insts - return IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - --- | Create a new 'IndefUnitId' given an explicit module substitution. -newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId -newIndefUnitId cid insts = - IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = sorted_insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - where - fs = hashUnitId cid sorted_insts - sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts - --- | Injects an 'IndefUnitId' (indefinite library which --- was on-the-fly instantiated) to a 'UnitId' (either --- an indefinite or definite library). -indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId -indefUnitIdToUnitId dflags iuid = - -- NB: suppose that we want to compare the indefinite - -- unit id p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- IndefiniteUnitId, they won't compare equal; only - -- after improvement will the equality hold. - improveUnitId (getUnitInfoMap dflags) $ - IndefiniteUnitId iuid - -data IndefModule = IndefModule { - indefModuleUnitId :: IndefUnitId, - indefModuleName :: ModuleName - } deriving (Eq, Ord) - -instance Outputable IndefModule where - ppr (IndefModule uid m) = - ppr uid <> char ':' <> ppr m - --- | Injects an 'IndefModule' to 'Module' (see also --- 'indefUnitIdToUnitId'. -indefModuleToModule :: DynFlags -> IndefModule -> Module -indefModuleToModule dflags (IndefModule iuid mod_name) = - mkModule (indefUnitIdToUnitId dflags iuid) mod_name - --- | An installed unit identifier identifies a library which has --- been installed to the package database. These strings are --- provided to us via the @-this-unit-id@ flag. The library --- in question may be definite or indefinite; if it is indefinite, --- none of the holes have been filled (we never install partially --- instantiated libraries.) Put another way, an installed unit id --- is either fully instantiated, or not instantiated at all. --- --- Installed unit identifiers look something like @p+af23SAj2dZ219@, --- or maybe just @p@ if they don't use Backpack. -newtype InstalledUnitId = - InstalledUnitId { - -- | The full hashed unit identifier, including the component id - -- and the hash. - installedUnitIdFS :: FastString - } - -instance Binary InstalledUnitId where - put_ bh (InstalledUnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (InstalledUnitId fs) - -instance BinaryStringRep InstalledUnitId where - fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) - -- GHC doesn't write to database - toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" - -instance Eq InstalledUnitId where - uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 - -instance Ord InstalledUnitId where - u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 - -instance Uniquable InstalledUnitId where - getUnique = installedUnitIdKey - -instance Outputable InstalledUnitId where - ppr uid@(InstalledUnitId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case displayInstalledUnitId dflags uid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -installedUnitIdKey :: InstalledUnitId -> Unique -installedUnitIdKey = getUnique . installedUnitIdFS - --- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. -toInstalledUnitId :: UnitId -> InstalledUnitId -toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid -toInstalledUnitId (IndefiniteUnitId indef) = - componentIdToInstalledUnitId (indefUnitIdComponentId indef) - -installedUnitIdString :: InstalledUnitId -> String -installedUnitIdString = unpackFS . installedUnitIdFS - -instance Outputable IndefUnitId where - ppr uid = - -- getPprStyle $ \sty -> - ppr cid <> - (if not (null insts) -- pprIf - then - brackets (hcat - (punctuate comma $ - [ ppr modname <> text "=" <> ppr m - | (modname, m) <- insts])) - else empty) - where - cid = indefUnitIdComponentId uid - insts = indefUnitIdInsts uid - --- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. -data InstalledModule = InstalledModule { - installedModuleUnitId :: !InstalledUnitId, - installedModuleName :: !ModuleName - } - deriving (Eq, Ord) - -instance Outputable InstalledModule where - ppr (InstalledModule p n) = - ppr p <> char ':' <> pprModuleName n - -fsToInstalledUnitId :: FastString -> InstalledUnitId -fsToInstalledUnitId fs = InstalledUnitId fs - -componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId -componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs - -stringToInstalledUnitId :: String -> InstalledUnitId -stringToInstalledUnitId = fsToInstalledUnitId . mkFastString - --- | Test if a 'Module' corresponds to a given 'InstalledModule', --- modulo instantiation. -installedModuleEq :: InstalledModule -> Module -> Bool -installedModuleEq imod mod = - fst (splitModuleInsts mod) == imod - --- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', --- modulo instantiation. -installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool -installedUnitIdEq iuid uid = - fst (splitUnitIdInsts uid) == iuid - --- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that --- it only refers to a definite library; i.e., one we have generated --- code for. -newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } - deriving (Eq, Ord) - -instance Outputable DefUnitId where - ppr (DefUnitId uid) = ppr uid - -instance Binary DefUnitId where - put_ bh (DefUnitId uid) = put_ bh uid - get bh = do uid <- get bh; return (DefUnitId uid) - --- | A map keyed off of 'InstalledModule' -newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) - -emptyInstalledModuleEnv :: InstalledModuleEnv a -emptyInstalledModuleEnv = InstalledModuleEnv Map.empty - -lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a -lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e - -extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a -extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) - -filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a -filterInstalledModuleEnv f (InstalledModuleEnv e) = - InstalledModuleEnv (Map.filterWithKey f e) - -delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a -delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) - --- Note [UnitId to InstalledUnitId improvement] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Just because a UnitId is definite (has no holes) doesn't --- mean it's necessarily a InstalledUnitId; it could just be --- that over the course of renaming UnitIds on the fly --- while typechecking an indefinite library, we --- ended up with a fully instantiated unit id with no hash, --- since we haven't built it yet. This is fine. --- --- However, if there is a hashed unit id for this instantiation --- in the package database, we *better use it*, because --- that hashed unit id may be lurking in another interface, --- and chaos will ensue if we attempt to compare the two --- (the unitIdFS for a UnitId never corresponds to a Cabal-provided --- hash of a compiled instantiated library). --- --- There is one last niggle: improvement based on the package database means --- that we might end up developing on a package that is not transitively --- depended upon by the packages the user specified directly via command line --- flags. This could lead to strange and difficult to understand bugs if those --- instantiations are out of date. The solution is to only improve a --- unit id if the new unit id is part of the 'preloadClosure'; i.e., the --- closure of all the packages which were explicitly specified. - --- | Retrieve the set of free holes of a 'UnitId'. -unitIdFreeHoles :: UnitId -> UniqDSet ModuleName -unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x --- Hashed unit ids are always fully instantiated -unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet - -instance Show UnitId where - show = unitIdString - --- | A 'UnitId' is definite if it has no free holes. -unitIdIsDefinite :: UnitId -> Bool -unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles - --- | Generate a uniquely identifying 'FastString' for a unit --- identifier. This is a one-way function. You can rely on one special --- property: if a unit identifier is in most general form, its 'FastString' --- coincides with its 'ComponentId'. This hash is completely internal --- to GHC and is not used for symbol names or file paths. -hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString -hashUnitId cid sorted_holes = - mkFastStringByteString - . fingerprintUnitId (toStringRep cid) - $ rawHashUnitId sorted_holes - --- | Generate a hash for a sorted module substitution. -rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint -rawHashUnitId sorted_holes = - fingerprintByteString - . BS.concat $ do - (m, b) <- sorted_holes - [ toStringRep m, BS.Char8.singleton ' ', - bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', - toStringRep (moduleName b), BS.Char8.singleton '\n'] - -fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString -fingerprintUnitId prefix (Fingerprint a b) - = BS.concat - $ [ prefix - , BS.Char8.singleton '-' - , BS.Char8.pack (toBase62Padded a) - , BS.Char8.pack (toBase62Padded b) ] - --- | Create a new, un-hashed unit identifier. -newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId -newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... -newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts - -pprUnitId :: UnitId -> SDoc -pprUnitId (DefiniteUnitId uid) = ppr uid -pprUnitId (IndefiniteUnitId uid) = ppr uid - -instance Eq UnitId where - uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 - -instance Uniquable UnitId where - getUnique = unitIdKey - -instance Ord UnitId where - nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 - -instance Data UnitId where - -- don't traverse? - toConstr _ = abstractConstr "UnitId" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "UnitId" - -instance NFData UnitId where - rnf x = x `seq` () - -stableUnitIdCmp :: UnitId -> UnitId -> Ordering --- ^ Compares package ids lexically, rather than by their 'Unique's -stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 - -instance Outputable UnitId where - ppr pk = pprUnitId pk - --- Performance: would prefer to have a NameCache like thing -instance Binary UnitId where - put_ bh (DefiniteUnitId def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (IndefiniteUnitId indef_uid) = do - putByte bh 1 - put_ bh indef_uid - get bh = do b <- getByte bh - case b of - 0 -> fmap DefiniteUnitId (get bh) - _ -> fmap IndefiniteUnitId (get bh) - -instance Binary ComponentId where - put_ bh (ComponentId fs) = put_ bh fs - get bh = do { fs <- get bh; return (ComponentId fs) } - --- | Create a new simple unit identifier (no holes) from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId (ComponentId fs) = fsToUnitId fs - --- | Create a new simple unit identifier from a 'FastString'. Internally, --- this is primarily used to specify wired-in unit identifiers. -fsToUnitId :: FastString -> UnitId -fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId - -stringToUnitId :: String -> UnitId -stringToUnitId = fsToUnitId . mkFastString - -unitIdString :: UnitId -> String -unitIdString = unpackFS . unitIdFS - -{- -************************************************************************ -* * - Hole substitutions -* * -************************************************************************ --} - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module - --- | Substitutes holes in a 'Module'. NOT suitable for being called --- directly on a 'nameModule', see Note [Representation of module/name variable]. --- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; --- similarly, @@ maps to @q():A@. -renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module -renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags) - --- | Substitutes holes in a 'UnitId', suitable for renaming when --- an include occurs; see Note [Representation of module/name variable]. --- --- @p[A=]@ maps to @p[A=]@ with @A=@. -renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags) - --- | Like 'renameHoleModule', but requires only 'UnitInfoMap' --- so it can be used by "Packages". -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = , that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap' --- so it can be used by "Packages". -renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId' pkg_map env uid = - case uid of - (IndefiniteUnitId - IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts - , indefUnitIdFreeHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - -- Functorially apply the substitution to the instantiation, - -- then check the 'UnitInfoMap' to see if there is - -- a compiled version of this 'UnitId' we can improve to. - -- See Note [UnitId to InstalledUnitId] improvement - else improveUnitId pkg_map $ - newUnitId cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - --- | Given a possibly on-the-fly instantiated module, split it into --- a 'Module' that we definitely can find on-disk, as well as an --- instantiation if we need to instantiate it on the fly. If the --- instantiation is @Nothing@ no on-the-fly renaming is needed. -splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) -splitModuleInsts m = - let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) - in (InstalledModule uid (moduleName m), - fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) - --- | See 'splitModuleInsts'. -splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) -splitUnitIdInsts (IndefiniteUnitId iuid) = - (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) -splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) - -generalizeIndefUnitId :: IndefUnitId -> IndefUnitId -generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts } = - newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) - -generalizeIndefModule :: IndefModule -> IndefModule -generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n - -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") - -parseUnitId :: ReadP UnitId -parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId - where - parseFullUnitId = do - cid <- parseComponentId - insts <- parseModSubst - return (newUnitId cid insts) - parseDefiniteUnitId = do - s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") - return (stringToUnitId s) - parseSimpleUnitId = do - cid <- parseComponentId - return (newSimpleUnitId cid) - -parseComponentId :: ReadP ComponentId -parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -parseModuleId :: ReadP Module -parseModuleId = parseModuleVar <++ parseModule - where - parseModuleVar = do - _ <- Parse.char '<' - modname <- parseModuleName - _ <- Parse.char '>' - return (mkHoleModule modname) - parseModule = do - uid <- parseUnitId - _ <- Parse.char ':' - modname <- parseModuleName - return (mkModule uid modname) - -parseModSubst :: ReadP [(ModuleName, Module)] -parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') - . flip Parse.sepBy (Parse.char ',') - $ do k <- parseModuleName - _ <- Parse.char '=' - v <- parseModuleId - return (k, v) - - -{- -Note [Wired-in packages] -~~~~~~~~~~~~~~~~~~~~~~~~ - -Certain packages are known to the compiler, in that we know about certain -entities that reside in these packages, and the compiler needs to -declare static Modules and Names that refer to these packages. Hence -the wired-in packages can't include version numbers in their package UnitId, -since we don't want to bake the version numbers of these packages into GHC. - -So here's the plan. Wired-in packages are still versioned as -normal in the packages database, and you can still have multiple -versions of them installed. To the user, everything looks normal. - -However, for each invocation of GHC, only a single instance of each wired-in -package will be recognised (the desired one is selected via -@-package@\/@-hide-package@), and GHC will internally pretend that it has the -*unversioned* 'UnitId', including in .hi files and object file symbols. - -Unselected versions of wired-in packages will be ignored, as will any other -package that depends directly or indirectly on it (much as if you -had used @-ignore-package@). - -The affected packages are compiled with, e.g., @-this-unit-id base@, so that -the symbols in the object files have the unversioned unit id in their name. - -Make sure you change 'Packages.findWiredInPackages' if you add an entry here. - -For `integer-gmp`/`integer-simple` we also change the base name to -`integer-wired-in`, but this is fundamentally no different. -See Note [The integer library] in PrelNames. --} - -integerUnitId, primUnitId, - baseUnitId, rtsUnitId, - thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId -primUnitId = fsToUnitId (fsLit "ghc-prim") -integerUnitId = fsToUnitId (fsLit "integer-wired-in") - -- See Note [The integer library] in PrelNames -baseUnitId = fsToUnitId (fsLit "base") -rtsUnitId = fsToUnitId (fsLit "rts") -thUnitId = fsToUnitId (fsLit "template-haskell") -thisGhcUnitId = fsToUnitId (fsLit "ghc") -interactiveUnitId = fsToUnitId (fsLit "interactive") - --- | This is the package Id for the current program. It is the default --- package Id if you don't specify a package name. We don't add this prefix --- to symbol names, since there can be only one main package per program. -mainUnitId = fsToUnitId (fsLit "main") - --- | This is a fake package id used to provide identities to any un-implemented --- signatures. The set of hole identities is global over an entire compilation. --- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. --- See Note [Representation of module/name variables] -holeUnitId :: UnitId -holeUnitId = fsToUnitId (fsLit "hole") - -isInteractiveModule :: Module -> Bool -isInteractiveModule mod = moduleUnitId mod == interactiveUnitId - --- Note [Representation of module/name variables] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In our ICFP'16, we use to represent module holes, and {A.T} to represent --- name holes. This could have been represented by adding some new cases --- to the core data types, but this would have made the existing 'nameModule' --- and 'moduleUnitId' partial, which would have required a lot of modifications --- to existing code. --- --- Instead, we adopted the following encoding scheme: --- --- ===> hole:A --- {A.T} ===> hole:A.T --- --- This encoding is quite convenient, but it is also a bit dangerous too, --- because if you have a 'hole:A' you need to know if it's actually a --- 'Module' or just a module stored in a 'Name'; these two cases must be --- treated differently when doing substitutions. 'renameHoleModule' --- and 'renameHoleUnitId' assume they are NOT operating on a --- 'Name'; 'NameShape' handles name substitutions exclusively. - -isHoleModule :: Module -> Bool -isHoleModule mod = moduleUnitId mod == holeUnitId - -wiredInUnitIds :: [UnitId] -wiredInUnitIds = [ primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - thisGhcUnitId ] - -{- -************************************************************************ -* * -\subsection{@ModuleEnv@s} -* * -************************************************************************ --} - --- | A map keyed off of 'Module's -newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) - -{- -Note [ModuleEnv performance and determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To prevent accidental reintroduction of nondeterminism the Ord instance -for Module was changed to not depend on Unique ordering and to use the -lexicographic order. This is potentially expensive, but when measured -there was no difference in performance. - -To be on the safe side and not pessimize ModuleEnv uses nondeterministic -ordering on Module and normalizes by doing the lexicographic sort when -turning the env to a list. -See Note [Unique Determinism] for more information about the source of -nondeterminismand and Note [Deterministic UniqFM] for explanation of why -it matters for maps. --} - -newtype NDModule = NDModule { unNDModule :: Module } - deriving Eq - -- A wrapper for Module with faster nondeterministic Ord. - -- Don't export, See [ModuleEnv performance and determinism] - -instance Ord NDModule where - compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` - (getUnique n1 `nonDetCmpUnique` getUnique n2) - -filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv f (ModuleEnv e) = - ModuleEnv (Map.filterWithKey (f . unNDModule) e) - -elemModuleEnv :: Module -> ModuleEnv a -> Bool -elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e - -extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) - -extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a - -> ModuleEnv a -extendModuleEnvWith f (ModuleEnv e) m x = - ModuleEnv (Map.insertWith f (NDModule m) x e) - -extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList (ModuleEnv e) xs = - ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) - -extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] - -> ModuleEnv a -extendModuleEnvList_C f (ModuleEnv e) xs = - ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) - -plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = - ModuleEnv (Map.unionWith f e1 e2) - -delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnvList (ModuleEnv e) ms = - ModuleEnv (Map.deleteList (map NDModule ms) e) - -delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) - -plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) - -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e - -lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -lookupWithDefaultModuleEnv (ModuleEnv e) x m = - Map.findWithDefault x (NDModule m) e - -mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) - -mkModuleEnv :: [(Module, a)] -> ModuleEnv a -mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) - -emptyModuleEnv :: ModuleEnv a -emptyModuleEnv = ModuleEnv Map.empty - -moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvElts :: ModuleEnv a -> [a] -moduleEnvElts e = map snd $ moduleEnvToList e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvToList :: ModuleEnv a -> [(Module, a)] -moduleEnvToList (ModuleEnv e) = - sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] - -- See Note [ModuleEnv performance and determinism] - -unitModuleEnv :: Module -> a -> ModuleEnv a -unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) - -isEmptyModuleEnv :: ModuleEnv a -> Bool -isEmptyModuleEnv (ModuleEnv e) = Map.null e - --- | A set of 'Module's -type ModuleSet = Set NDModule - -mkModuleSet :: [Module] -> ModuleSet -mkModuleSet = Set.fromList . coerce - -extendModuleSet :: ModuleSet -> Module -> ModuleSet -extendModuleSet s m = Set.insert (NDModule m) s - -extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet -extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms - -emptyModuleSet :: ModuleSet -emptyModuleSet = Set.empty - -moduleSetElts :: ModuleSet -> [Module] -moduleSetElts = sort . coerce . Set.toList - -elemModuleSet :: Module -> ModuleSet -> Bool -elemModuleSet = Set.member . coerce - -intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -intersectModuleSet = coerce Set.intersection - -minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -minusModuleSet = coerce Set.difference - -delModuleSet :: ModuleSet -> Module -> ModuleSet -delModuleSet = coerce (flip Set.delete) - -unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -unionModuleSet = coerce Set.union - -unitModuleSet :: Module -> ModuleSet -unitModuleSet = coerce Set.singleton - -{- -A ModuleName has a Unique, so we can build mappings of these using -UniqFM. --} - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) -type ModuleNameEnv elt = UniqFM elt - - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) --- Has deterministic folds and can be deterministically converted to a list -type DModuleNameEnv elt = UniqDFM elt diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/Module.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module Module where - -import GhcPrelude -import FastString - -data Module -data ModuleName -data UnitId -data InstalledUnitId -newtype ComponentId = ComponentId FastString - -moduleName :: Module -> ModuleName -moduleUnitId :: Module -> UnitId -unitIdString :: UnitId -> String diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs deleted file mode 100644 --- a/compiler/basicTypes/Name.hs +++ /dev/null @@ -1,693 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Name]{@Name@: to transmit name info from renamer to typechecker} --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They --- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have --- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names --- also contain information about where they originated from, see "Name#name_sorts" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" --- --- #name_sorts# --- Names are one of: --- --- * External, if they name things declared in other modules. Some external --- Names are wired in, i.e. they name primitives defined in the compiler itself --- --- * Internal, if they name things in the module being compiled. Some internal --- Names are system names, if they are names manufactured by the compiler - -module Name ( - -- * The main types - Name, -- Abstract - BuiltInSyntax(..), - - -- ** Creating 'Name's - mkSystemName, mkSystemNameAt, - mkInternalName, mkClonedInternalName, mkDerivedInternalName, - mkSystemVarName, mkSysTvName, - mkFCallName, - mkExternalName, mkWiredInName, - - -- ** Manipulating and deconstructing 'Name's - nameUnique, setNameUnique, - nameOccName, nameNameSpace, nameModule, nameModule_maybe, - setNameLoc, - tidyNameOcc, - localiseName, - - nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, - - -- ** Predicates on 'Name's - isSystemName, isInternalName, isExternalName, - isTyVarName, isTyConName, isDataConName, - isValName, isVarName, - isWiredInName, isWiredIn, isBuiltInSyntax, - isHoleName, - wiredInNameTyThing_maybe, - nameIsLocalOrFrom, nameIsHomePackage, - nameIsHomePackageImport, nameIsFromExternalPackage, - stableNameCmp, - - -- * Class 'NamedThing' and overloaded friends - NamedThing(..), - getSrcLoc, getSrcSpan, getOccString, getOccFS, - - pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, - nameStableString, - - -- Re-export the OccName stuff - module OccName - ) where - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep( TyThing ) - -import OccName -import Module -import SrcLoc -import Unique -import Util -import Maybes -import Binary -import FastString -import Outputable - -import Control.DeepSeq -import Data.Data - -{- -************************************************************************ -* * -\subsection[Name-datatype]{The @Name@ datatype, and name construction} -* * -************************************************************************ --} - --- | A unique, unambiguous name for something, containing information about where --- that thing originated. -data Name = Name { - n_sort :: NameSort, -- What sort of name it is - n_occ :: !OccName, -- Its occurrence name - n_uniq :: {-# UNPACK #-} !Unique, - n_loc :: !SrcSpan -- Definition site - } - --- NOTE: we make the n_loc field strict to eliminate some potential --- (and real!) space leaks, due to the fact that we don't look at --- the SrcLoc in a Name all that often. - --- See Note [About the NameSorts] -data NameSort - = External Module - - | WiredIn Module TyThing BuiltInSyntax - -- A variant of External, for wired-in things - - | Internal -- A user-defined Id or TyVar - -- defined in the module being compiled - - | System -- A system-defined Id or TyVar. Typically the - -- OccName is very uninformative (like 's') - -instance Outputable NameSort where - ppr (External _) = text "external" - ppr (WiredIn _ _ _) = text "wired-in" - ppr Internal = text "internal" - ppr System = text "system" - -instance NFData Name where - rnf Name{..} = rnf n_sort - -instance NFData NameSort where - rnf (External m) = rnf m - rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () - -- XXX this is a *lie*, we're not going to rnf the TyThing, but - -- since the TyThings for WiredIn Names are all static they can't - -- be hiding space leaks or errors. - rnf Internal = () - rnf System = () - --- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, --- which have special syntactic forms. They aren't in scope --- as such. -data BuiltInSyntax = BuiltInSyntax | UserSyntax - -{- -Note [About the NameSorts] - -1. Initially, top-level Ids (including locally-defined ones) get External names, - and all other local Ids get Internal names - -2. In any invocation of GHC, an External Name for "M.x" has one and only one - unique. This unique association is ensured via the Name Cache; - see Note [The Name Cache] in GHC.Iface.Env. - -3. Things with a External name are given C static labels, so they finally - appear in the .o file's symbol table. They appear in the symbol table - in the form M.n. If originally-local things have this property they - must be made @External@ first. - -4. In the tidy-core phase, a External that is not visible to an importer - is changed to Internal, and a Internal that is visible is changed to External - -5. A System Name differs in the following ways: - a) has unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible - - Before anything gets printed in interface files or output code, it's - fed through a 'tidy' processor, which zaps the OccNames to have - unique names; and converts all sys-locals to user locals - If any desugarer sys-locals have survived that far, they get changed to - "ds1", "ds2", etc. - -Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) - -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others - -All built-in syntax is for wired-in things. --} - -instance HasOccName Name where - occName = nameOccName - -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameNameSpace :: Name -> NameSpace -nameModule :: HasDebugCallStack => Name -> Module -nameSrcLoc :: Name -> SrcLoc -nameSrcSpan :: Name -> SrcSpan - -nameUnique name = n_uniq name -nameOccName name = n_occ name -nameNameSpace name = occNameSpace (n_occ name) -nameSrcLoc name = srcSpanStart (n_loc name) -nameSrcSpan name = n_loc name - -{- -************************************************************************ -* * -\subsection{Predicates on names} -* * -************************************************************************ --} - -isInternalName :: Name -> Bool -isExternalName :: Name -> Bool -isSystemName :: Name -> Bool -isWiredInName :: Name -> Bool - -isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName _ = False - -isWiredIn :: NamedThing thing => thing -> Bool -isWiredIn = isWiredInName . getName - -wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe _ = Nothing - -isBuiltInSyntax :: Name -> Bool -isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax _ = False - -isExternalName (Name {n_sort = External _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName _ = False - -isInternalName name = not (isExternalName name) - -isHoleName :: Name -> Bool -isHoleName = isHoleModule . nameModule - -nameModule name = - nameModule_maybe name `orElse` - pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) - -nameModule_maybe :: Name -> Maybe Module -nameModule_maybe (Name { n_sort = External mod}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe _ = Nothing - -nameIsLocalOrFrom :: Module -> Name -> Bool --- ^ Returns True if the name is --- (a) Internal --- (b) External but from the specified module --- (c) External but from the 'interactive' package --- --- The key idea is that --- False means: the entity is defined in some other module --- you can find the details (type, fixity, instances) --- in some interface file --- those details will be stored in the EPT or HPT --- --- True means: the entity is defined in this module or earlier in --- the GHCi session --- you can find details (type, fixity, instances) in the --- TcGblEnv or TcLclEnv --- --- The isInteractiveModule part is because successive interactions of a GHCi session --- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come --- from the magic 'interactive' package; and all the details are kept in the --- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. --- See Note [The interactive package] in GHC.Driver.Types - -nameIsLocalOrFrom from name - | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod - | otherwise = True - -nameIsHomePackage :: Module -> Name -> Bool --- True if the Name is defined in module of this package -nameIsHomePackage this_mod - = \nm -> case n_sort nm of - External nm_mod -> moduleUnitId nm_mod == this_pkg - WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg - Internal -> True - System -> False - where - this_pkg = moduleUnitId this_mod - -nameIsHomePackageImport :: Module -> Name -> Bool --- True if the Name is defined in module of this package --- /other than/ the this_mod -nameIsHomePackageImport this_mod - = \nm -> case nameModule_maybe nm of - Nothing -> False - Just nm_mod -> nm_mod /= this_mod - && moduleUnitId nm_mod == this_pkg - where - this_pkg = moduleUnitId this_mod - --- | Returns True if the Name comes from some other package: neither this --- package nor the interactive package. -nameIsFromExternalPackage :: UnitId -> Name -> Bool -nameIsFromExternalPackage this_pkg name - | Just mod <- nameModule_maybe name - , moduleUnitId mod /= this_pkg -- Not this package - , not (isInteractiveModule mod) -- Not the 'interactive' package - = True - | otherwise - = False - -isTyVarName :: Name -> Bool -isTyVarName name = isTvOcc (nameOccName name) - -isTyConName :: Name -> Bool -isTyConName name = isTcOcc (nameOccName name) - -isDataConName :: Name -> Bool -isDataConName name = isDataOcc (nameOccName name) - -isValName :: Name -> Bool -isValName name = isValOcc (nameOccName name) - -isVarName :: Name -> Bool -isVarName = isVarOcc . nameOccName - -isSystemName (Name {n_sort = System}) = True -isSystemName _ = False - -{- -************************************************************************ -* * -\subsection{Making names} -* * -************************************************************************ --} - --- | Create a name which is (for now at least) local to the current module and hence --- does not need a 'Module' to disambiguate it from other 'Name's -mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = uniq - , n_sort = Internal - , n_occ = occ - , n_loc = loc } - -- NB: You might worry that after lots of huffing and - -- puffing we might end up with two local names with distinct - -- uniques, but the same OccName. Indeed we can, but that's ok - -- * the insides of the compiler don't care: they use the Unique - -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the - -- uniques if you get confused - -- * for interface files we tidyCore first, which makes - -- the OccNames distinct when they need to be - -mkClonedInternalName :: Unique -> Name -> Name -mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = uniq, n_sort = Internal - , n_occ = occ, n_loc = loc } - -mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name -mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = uniq, n_sort = Internal - , n_occ = derive_occ occ, n_loc = loc } - --- | Create a name which definitely originates in the given module -mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name --- WATCH OUT! External Names should be in the Name Cache --- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName --- with some fresh unique without populating the Name Cache -mkExternalName uniq mod occ loc - = Name { n_uniq = uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - --- | Create a name which is actually defined by the compiler itself -mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = uniq, - n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcSpan } - --- | Create a name brought into being by the compiler -mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan - -mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name -mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System - , n_occ = occ, n_loc = loc } - -mkSystemVarName :: Unique -> FastString -> Name -mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) - -mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) - --- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan - -- The encoded string completely describes the ccall - --- When we renumber/rename things, we need to be --- able to change a Name's Unique to match the cached --- one in the thing it's the name of. If you know what I mean. -setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = uniq} - --- This is used for hsigs: we want to use the name of the originally exported --- entity, but edit the location to refer to the reexport site -setNameLoc :: Name -> SrcSpan -> Name -setNameLoc name loc = name {n_loc = loc} - -tidyNameOcc :: Name -> OccName -> Name --- We set the OccName of a Name when tidying --- In doing so, we change System --> Internal, so that when we print --- it we don't get the unique by default. It's tidy now! -tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} -tidyNameOcc name occ = name { n_occ = occ } - --- | Make the 'Name' into an internal name, regardless of what it was to begin with -localiseName :: Name -> Name -localiseName n = n { n_sort = Internal } - -{- -************************************************************************ -* * -\subsection{Hashing and comparison} -* * -************************************************************************ --} - -cmpName :: Name -> Name -> Ordering -cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 - --- | Compare Names lexicographically --- This only works for Names that originate in the source code or have been --- tidied. -stableNameCmp :: Name -> Name -> Ordering -stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) - (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) - -- The ordinary compare on OccNames is lexicographic - where - -- Later constructors are bigger - sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 - sort_cmp (External {}) _ = LT - sort_cmp (WiredIn {}) (External {}) = GT - sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 - sort_cmp (WiredIn {}) _ = LT - sort_cmp Internal (External {}) = GT - sort_cmp Internal (WiredIn {}) = GT - sort_cmp Internal Internal = EQ - sort_cmp Internal System = LT - sort_cmp System System = EQ - sort_cmp System _ = GT - -{- -************************************************************************ -* * -\subsection[Name-instances]{Instance declarations} -* * -************************************************************************ --} - --- | The same comments as for `Name`'s `Ord` instance apply. -instance Eq Name where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - --- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which --- means that the ordering is not stable across deserialization or rebuilds. --- --- See `nonDetCmpUnique` for further information, and trac #15240 for a bug --- caused by improper use of this instance. - --- For a deterministic lexicographic ordering, use `stableNameCmp`. -instance Ord Name where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpName a b - -instance Uniquable Name where - getUnique = nameUnique - -instance NamedThing Name where - getName n = n - -instance Data Name where - -- don't traverse? - toConstr _ = abstractConstr "Name" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Name" - -{- -************************************************************************ -* * -\subsection{Binary} -* * -************************************************************************ --} - --- | Assumes that the 'Name' is a non-binding one. See --- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for --- serializing binding 'Name's. See 'UserData' for the rationale for this --- distinction. -instance Binary Name where - put_ bh name = - case getUserData bh of - UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name - - get bh = - case getUserData bh of - UserData { ud_get_name = get_name } -> get_name bh - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance Outputable Name where - ppr name = pprName name - -instance OutputableBndr Name where - pprBndr _ name = pprName name - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName - -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \ sty -> - case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ - --- | Print the string of Name unqualifiedly directly. -pprNameUnqualified :: Name -> SDoc -pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ - -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? - | debugStyle sty = pp_mod <> ppr_occ_name occ - <> braces (hsep [if is_wired then text "(w)" else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = - if isHoleModule mod - then case qualName sty mod occ of - NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) - else pprModulePrefix sty mod occ <> ppr_occ_name occ - where - pp_mod = ppUnlessOption sdocSuppressModulePrefixes - (ppr mod <> dot) - -pprInternal :: PprStyle -> Unique -> OccName -> SDoc -pprInternal sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - -- For debug dumps, we're not necessarily dumping - -- tidied code, so we need to print the uniques. - | otherwise = ppr_occ_name occ -- User style - --- Like Internal, except that we only omit the unique in Iface style -pprSystem :: PprStyle -> Unique -> OccName -> SDoc -pprSystem sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq - -- If the tidy phase hasn't run, the OccName - -- is unlikely to be informative (like 's'), - -- so print the unique - - -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc --- Print the "M." part of a name, based on whether it's in scope or not --- See Note [Printing original names] in GHC.Driver.Types -pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ - case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either - NameUnqual -> empty -- In scope unqualified - -pprUnique :: Unique -> SDoc --- Print a unique unless we are suppressing them -pprUnique uniq - = ppUnlessOption sdocSuppressUniques $ - pprUniqueAlways uniq - -ppr_underscore_unique :: Unique -> SDoc --- Print an underscore separating the name from its unique --- But suppress it if we aren't printing the uniques anyway -ppr_underscore_unique uniq - = ppUnlessOption sdocSuppressUniques $ - char '_' <> pprUniqueAlways uniq - -ppr_occ_name :: OccName -> SDoc -ppr_occ_name occ = ftext (occNameFS occ) - -- Don't use pprOccName; instead, just print the string of the OccName; - -- we print the namespace in the debug stuff above - --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc -ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) - --- Prints (if mod information is available) "Defined at " or --- "Defined in " information for a Name. -pprDefinedAt :: Name -> SDoc -pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name - -pprNameDefnLoc :: Name -> SDoc --- Prints "at " or --- or "in " depending on what info is available -pprNameDefnLoc name - = case nameSrcLoc name of - -- nameSrcLoc rather than nameSrcSpan - -- It seems less cluttered to show a location - -- rather than a span for the definition point - RealSrcLoc s _ -> text "at" <+> ppr s - UnhelpfulLoc s - | isInternalName name || isSystemName name - -> text "at" <+> ftext s - | otherwise - -> text "in" <+> quotes (ppr (nameModule name)) - - --- | Get a string representation of a 'Name' that's unique and stable --- across recompilations. Used for deterministic generation of binds for --- derived instances. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" -nameStableString :: Name -> String -nameStableString Name{..} = - nameSortStableString n_sort ++ "$" ++ occNameString n_occ - -nameSortStableString :: NameSort -> String -nameSortStableString System = "$_sys" -nameSortStableString Internal = "$_in" -nameSortStableString (External mod) = moduleStableString mod -nameSortStableString (WiredIn mod _ _) = moduleStableString mod - -{- -************************************************************************ -* * -\subsection{Overloaded functions related to Names} -* * -************************************************************************ --} - --- | A class allowing convenient access to the 'Name' of various datatypes -class NamedThing a where - getOccName :: a -> OccName - getName :: a -> Name - - getOccName n = nameOccName (getName n) -- Default method - -instance NamedThing e => NamedThing (Located e) where - getName = getName . unLoc - -getSrcLoc :: NamedThing a => a -> SrcLoc -getSrcSpan :: NamedThing a => a -> SrcSpan -getOccString :: NamedThing a => a -> String -getOccFS :: NamedThing a => a -> FastString - -getSrcLoc = nameSrcLoc . getName -getSrcSpan = nameSrcSpan . getName -getOccString = occNameString . getOccName -getOccFS = occNameFS . getOccName - -pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc --- See Outputable.pprPrefixVar, pprInfixVar; --- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) - -pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) - where - name = getName thing diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/Name.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Name where - -import GhcPrelude () - -data Name diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs deleted file mode 100644 --- a/compiler/basicTypes/NameCache.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - --- | The Name Cache -module NameCache - ( lookupOrigNameCache - , extendOrigNameCache - , extendNameCache - , initNameCache - , NameCache(..), OrigNameCache - ) where - -import GhcPrelude - -import Module -import Name -import UniqSupply -import TysWiredIn -import Util -import Outputable -import PrelNames - -#include "HsVersions.h" - -{- - -Note [The Name Cache] -~~~~~~~~~~~~~~~~~~~~~ -The Name Cache makes sure that, during any invocation of GHC, each -External Name "M.x" has one, and only one globally-agreed Unique. - -* The first time we come across M.x we make up a Unique and record that - association in the Name Cache. - -* When we come across "M.x" again, we look it up in the Name Cache, - and get a hit. - -The functions newGlobalBinder, allocateGlobalBinder do the main work. -When you make an External name, you should probably be calling one -of them. - - -Note [Built-in syntax and the OrigNameCache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower -their cost we use two tricks, - - a. We specially encode tuple and sum Names in interface files' symbol tables - to avoid having to look up their names while loading interface files. - Namely these names are encoded as by their Uniques. We know how to get from - a Unique back to the Name which it represents via the mapping defined in - the SumTupleUniques module. See Note [Symbol table representation of names] - in GHC.Iface.Binary and for details. - - b. We don't include them in the Orig name cache but instead parse their - OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with - them. - -Why is the second measure necessary? Good question; afterall, 1) the parser -emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never -needs to looked-up during interface loading due to (a). It turns out that there -are two reasons why we might look up an Orig RdrName for built-in syntax, - - * If you use setRdrNameSpace on an Exact RdrName it may be - turned into an Orig RdrName. - - * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName - (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will - go this route (#8954). - --} - --- | Per-module cache of original 'OccName's given 'Name's -type OrigNameCache = ModuleEnv (OccEnv Name) - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE - , Just name <- isBuiltInOcc_maybe occ - = -- See Note [Known-key names], 3(c) in PrelNames - -- Special case for tuples; there are too many - -- of them to pre-populate the original-name cache - Just name - - | otherwise - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just occ_env -> lookupOccEnv occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = ASSERT2( isExternalName name, ppr name ) - extendNameCache nc (nameModule name) (nameOccName name) name - -extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extendNameCache nc mod occ name - = extendModuleEnvWith combine nc mod (unitOccEnv occ name) - where - combine _ occ_env = extendOccEnv occ_env occ name - --- | The NameCache makes sure that there is just one Unique assigned for --- each original name; i.e. (module-name, occ-name) pair and provides --- something of a lookup mechanism for those names. -data NameCache - = NameCache { nsUniqs :: !UniqSupply, - -- ^ Supply of uniques - nsNames :: !OrigNameCache - -- ^ Ensures that one original name gets one unique - } - --- | Return a function to atomically update the name cache. -initNameCache :: UniqSupply -> [Name] -> NameCache -initNameCache us names - = NameCache { nsUniqs = us, - nsNames = initOrigNames names } - -initOrigNames :: [Name] -> OrigNameCache -initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs deleted file mode 100644 --- a/compiler/basicTypes/NameEnv.hs +++ /dev/null @@ -1,175 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[NameEnv]{@NameEnv@: name environments} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module NameEnv ( - -- * Var, Id and TyVar environments (maps) - NameEnv, - - -- ** Manipulating these environments - mkNameEnv, mkNameEnvWith, - emptyNameEnv, isEmptyNameEnv, - unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, - extendNameEnvList, extendNameEnvList_C, - filterNameEnv, anyNameEnv, - plusNameEnv, plusNameEnv_C, alterNameEnv, - lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv, mapNameEnv, disjointNameEnv, - - DNameEnv, - - emptyDNameEnv, - lookupDNameEnv, - delFromDNameEnv, filterDNameEnv, - mapDNameEnv, - adjustDNameEnv, alterDNameEnv, extendDNameEnv, - -- ** Dependency analysis - depAnal - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Digraph -import Name -import UniqFM -import UniqDFM -import Maybes - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - -{- -Note [depAnal determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -depAnal is deterministic provided it gets the nodes in a deterministic order. -The order of lists that get_defs and get_uses return doesn't matter, as these -are only used to construct the edges, and stronglyConnCompFromEdgedVertices is -deterministic even when the edges are not in deterministic order as explained -in Note [Deterministic SCC] in Digraph. --} - -depAnal :: forall node. - (node -> [Name]) -- Defs - -> (node -> [Name]) -- Uses - -> [node] - -> [SCC node] --- Perform dependency analysis on a group of definitions, --- where each definition may define more than one Name --- --- The get_defs and get_uses functions are called only once per node -depAnal get_defs get_uses nodes - = stronglyConnCompFromEdgedVerticesUniq graph_nodes - where - graph_nodes = (map mk_node keyed_nodes) :: [Node Int node] - keyed_nodes = nodes `zip` [(1::Int)..] - mk_node (node, key) = - let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node)) - in DigraphNode node key edges - - key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it - key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - --- | Name Environment -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -isEmptyNameEnv :: NameEnv a -> Bool -mkNameEnv :: [(Name,a)] -> NameEnv a -mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a -nameEnvElts :: NameEnv a -> [a] -alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a -extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b -extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a -extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -lookupNameEnv_NF :: NameEnv a -> Name -> a -filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt -anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool -mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 -disjointNameEnv :: NameEnv a -> NameEnv a -> Bool - -nameEnvElts x = eltsUFM x -emptyNameEnv = emptyUFM -isEmptyNameEnv = isNullUFM -unitNameEnv x y = unitUFM x y -extendNameEnv x y z = addToUFM x y z -extendNameEnvList x l = addListToUFM x l -lookupNameEnv x y = lookupUFM x y -alterNameEnv = alterUFM -mkNameEnv l = listToUFM l -mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) -elemNameEnv x y = elemUFM x y -plusNameEnv x y = plusUFM x y -plusNameEnv_C f x y = plusUFM_C f x y -extendNameEnv_C f x y z = addToUFM_C f x y z -mapNameEnv f x = mapUFM f x -extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendNameEnvList_C x y z = addListToUFM_C x y z -delFromNameEnv x y = delFromUFM x y -delListFromNameEnv x y = delListFromUFM x y -filterNameEnv x y = filterUFM x y -anyNameEnv f x = foldUFM ((||) . f) False x -disjointNameEnv x y = isNullUFM (intersectUFM x y) - -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) - --- | Deterministic Name Environment --- --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DNameEnv. -type DNameEnv a = UniqDFM a - -emptyDNameEnv :: DNameEnv a -emptyDNameEnv = emptyUDFM - -lookupDNameEnv :: DNameEnv a -> Name -> Maybe a -lookupDNameEnv = lookupUDFM - -delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a -delFromDNameEnv = delFromUDFM - -filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a -filterDNameEnv = filterUDFM - -mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b -mapDNameEnv = mapUDFM - -adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a -adjustDNameEnv = adjustUDFM - -alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a -alterDNameEnv = alterUDFM - -extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a -extendDNameEnv = addToUDFM diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs deleted file mode 100644 --- a/compiler/basicTypes/NameSet.hs +++ /dev/null @@ -1,215 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 --} - -{-# LANGUAGE CPP #-} -module NameSet ( - -- * Names set type - NameSet, - - -- ** Manipulating these sets - emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, - minusNameSet, elemNameSet, extendNameSet, extendNameSetList, - delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, - intersectsNameSet, intersectNameSet, - nameSetAny, nameSetAll, nameSetElemsStable, - - -- * Free variables - FreeVars, - - -- ** Manipulating sets of free variables - isEmptyFVs, emptyFVs, plusFVs, plusFV, - mkFVs, addOneFV, unitFV, delFV, delFVs, - intersectFVs, - - -- * Defs and uses - Defs, Uses, DefUse, DefUses, - - -- ** Manipulating defs and uses - emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses, allUses - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Name -import OrdList -import UniqSet -import Data.List (sortBy) - -{- -************************************************************************ -* * -\subsection[Sets of names} -* * -************************************************************************ --} - -type NameSet = UniqSet Name - -emptyNameSet :: NameSet -unitNameSet :: Name -> NameSet -extendNameSetList :: NameSet -> [Name] -> NameSet -extendNameSet :: NameSet -> Name -> NameSet -mkNameSet :: [Name] -> NameSet -unionNameSet :: NameSet -> NameSet -> NameSet -unionNameSets :: [NameSet] -> NameSet -minusNameSet :: NameSet -> NameSet -> NameSet -elemNameSet :: Name -> NameSet -> Bool -isEmptyNameSet :: NameSet -> Bool -delFromNameSet :: NameSet -> Name -> NameSet -delListFromNameSet :: NameSet -> [Name] -> NameSet -filterNameSet :: (Name -> Bool) -> NameSet -> NameSet -intersectNameSet :: NameSet -> NameSet -> NameSet -intersectsNameSet :: NameSet -> NameSet -> Bool --- ^ True if there is a non-empty intersection. --- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty - -isEmptyNameSet = isEmptyUniqSet -emptyNameSet = emptyUniqSet -unitNameSet = unitUniqSet -mkNameSet = mkUniqSet -extendNameSetList = addListToUniqSet -extendNameSet = addOneToUniqSet -unionNameSet = unionUniqSets -unionNameSets = unionManyUniqSets -minusNameSet = minusUniqSet -elemNameSet = elementOfUniqSet -delFromNameSet = delOneFromUniqSet -filterNameSet = filterUniqSet -intersectNameSet = intersectUniqSets - -delListFromNameSet set ns = foldl' delFromNameSet set ns - -intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) - -nameSetAny :: (Name -> Bool) -> NameSet -> Bool -nameSetAny = uniqSetAny - -nameSetAll :: (Name -> Bool) -> NameSet -> Bool -nameSetAll = uniqSetAll - --- | Get the elements of a NameSet with some stable ordering. --- This only works for Names that originate in the source code or have been --- tidied. --- See Note [Deterministic UniqFM] to learn about nondeterminism -nameSetElemsStable :: NameSet -> [Name] -nameSetElemsStable ns = - sortBy stableNameCmp $ nonDetEltsUniqSet ns - -- It's OK to use nonDetEltsUniqSet here because we immediately sort - -- with stableNameCmp - -{- -************************************************************************ -* * -\subsection{Free variables} -* * -************************************************************************ - -These synonyms are useful when we are thinking of free variables --} - -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars -delFV :: Name -> FreeVars -> FreeVars -delFVs :: [Name] -> FreeVars -> FreeVars -intersectFVs :: FreeVars -> FreeVars -> FreeVars - -isEmptyFVs :: NameSet -> Bool -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionNameSets -plusFV = unionNameSet -mkFVs = mkNameSet -addOneFV = extendNameSet -unitFV = unitNameSet -delFV n s = delFromNameSet s n -delFVs ns s = delListFromNameSet s ns -intersectFVs = intersectNameSet - -{- -************************************************************************ -* * - Defs and uses -* * -************************************************************************ --} - --- | A set of names that are defined somewhere -type Defs = NameSet - --- | A set of names that are used somewhere -type Uses = NameSet - --- | @(Just ds, us) =>@ The use of any member of the @ds@ --- implies that all the @us@ are used too. --- Also, @us@ may mention @ds@. --- --- @Nothing =>@ Nothing is defined in this group, but --- nevertheless all the uses are essential. --- Used for instance declarations, for example -type DefUse = (Maybe Defs, Uses) - --- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' --- In a single (def, use) pair, the defs also scope over the uses -type DefUses = OrdList DefUse - -emptyDUs :: DefUses -emptyDUs = nilOL - -usesOnly :: Uses -> DefUses -usesOnly uses = unitOL (Nothing, uses) - -mkDUs :: [(Defs,Uses)] -> DefUses -mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] - -plusDU :: DefUses -> DefUses -> DefUses -plusDU = appOL - -duDefs :: DefUses -> Defs -duDefs dus = foldr get emptyNameSet dus - where - get (Nothing, _u1) d2 = d2 - get (Just d1, _u1) d2 = d1 `unionNameSet` d2 - -allUses :: DefUses -> Uses --- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned -allUses dus = foldr get emptyNameSet dus - where - get (_d1, u1) u2 = u1 `unionNameSet` u2 - -duUses :: DefUses -> Uses --- ^ Collect all 'Uses', regardless of whether the group is itself used, --- but remove 'Defs' on the way -duUses dus = foldr get emptyNameSet dus - where - get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) - `minusNameSet` defs - -findUses :: DefUses -> Uses -> Uses --- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. --- The result is a superset of the input 'Uses'; and includes things defined --- in the input 'DefUses' (but only if they are used) -findUses dus uses - = foldr get uses dus - where - get (Nothing, rhs_uses) uses - = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses - | defs `intersectsNameSet` uses -- Used - || nameSetAny (startsWithUnderscore . nameOccName) defs - -- At least one starts with an "_", - -- so treat the group as used - = rhs_uses `unionNameSet` uses - | otherwise -- No def is used - = uses diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs deleted file mode 100644 --- a/compiler/basicTypes/OccName.hs +++ /dev/null @@ -1,927 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName' represents names as strings with just a little more information: --- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or --- data constructors --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module OccName ( - -- * The 'NameSpace' type - NameSpace, -- Abstract - - nameSpacesRelated, - - -- ** Construction - -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, - - -- ** Pretty Printing - pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, - - -- * The 'OccName' type - OccName, -- Abstract, instance of Outputable - pprOccName, - - -- ** Construction - mkOccName, mkOccNameFS, - mkVarOcc, mkVarOccFS, - mkDataOcc, mkDataOccFS, - mkTyVarOcc, mkTyVarOccFS, - mkTcOcc, mkTcOccFS, - mkClsOcc, mkClsOccFS, - mkDFunOcc, - setOccNameSpace, - demoteOccName, - HasOccName(..), - - -- ** Derived 'OccName's - isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, - mkNewTyCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, - mkSuperDictSelOcc, mkSuperDictAuxOcc, - mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, - mkInstTyCoOcc, mkEqPredCoOcc, - mkRecFldSelOcc, - mkTyConRepOcc, - - -- ** Deconstruction - occNameFS, occNameString, occNameSpace, - - isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - parenSymOcc, startsWithUnderscore, - - isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, - - -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, pprOccEnv, - - -- * The 'OccSet' type - OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, - extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, - isEmptyOccSet, intersectOccSet, intersectsOccSet, - filterOccSet, - - -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, - tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, - - -- FsEnv - FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv - ) where - -import GhcPrelude - -import Util -import Unique -import UniqFM -import UniqSet -import FastString -import FastStringEnv -import Outputable -import Lexeme -import Binary -import Control.DeepSeq -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsection{Name space} -* * -************************************************************************ --} - -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) - --- Note [Data Constructors] --- see also: Note [Data Constructor Naming] in DataCon.hs --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. - -tcName, clsName, tcClsName :: NameSpace -dataName, srcDataName :: NameSpace -tvName, varName :: NameSpace - --- Though type constructors and classes are in the same name space now, --- the NameSpace type is abstract, so we can easily separate them later -tcName = TcClsName -- Type constructors -clsName = TcClsName -- Classes -tcClsName = TcClsName -- Not sure which! - -dataName = DataName -srcDataName = DataName -- Haskell-source data constructors should be - -- in the Data name space - -tvName = TvName -varName = VarName - -isDataConNameSpace :: NameSpace -> Bool -isDataConNameSpace DataName = True -isDataConNameSpace _ = False - -isTcClsNameSpace :: NameSpace -> Bool -isTcClsNameSpace TcClsName = True -isTcClsNameSpace _ = False - -isTvNameSpace :: NameSpace -> Bool -isTvNameSpace TvName = True -isTvNameSpace _ = False - -isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False - -isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False - -pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = text "data constructor" -pprNameSpace VarName = text "variable" -pprNameSpace TvName = text "type variable" -pprNameSpace TcClsName = text "type constructor or class" - -pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty -pprNonVarNameSpace ns = pprNameSpace ns - -pprNameSpaceBrief :: NameSpace -> SDoc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = text "tv" -pprNameSpaceBrief TcClsName = text "tc" - --- demoteNameSpace lowers the NameSpace if possible. We can not know --- in advance, since a TvName can appear in an HsTyVar. --- See Note [Demotion] in GHC.Rename.Env -demoteNameSpace :: NameSpace -> Maybe NameSpace -demoteNameSpace VarName = Nothing -demoteNameSpace DataName = Nothing -demoteNameSpace TvName = Nothing -demoteNameSpace TcClsName = Just DataName - -{- -************************************************************************ -* * -\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} -* * -************************************************************************ --} - --- | Occurrence Name --- --- In this context that means: --- "classified (i.e. as a type name, value name, etc) but not qualified --- and not yet resolved" -data OccName = OccName - { occNameSpace :: !NameSpace - , occNameFS :: !FastString - } - -instance Eq OccName where - (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 - -instance Ord OccName where - -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) - -instance Data OccName where - -- don't traverse? - toConstr _ = abstractConstr "OccName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "OccName" - -instance HasOccName OccName where - occName = id - -instance NFData OccName where - rnf x = x `seq` () - -{- -************************************************************************ -* * -\subsection{Printing} -* * -************************************************************************ --} - -instance Outputable OccName where - ppr = pprOccName - -instance OutputableBndr OccName where - pprBndr _ = ppr - pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) - pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) - -pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS occ) - else pp_occ <> pp_debug sty - where - pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) - | otherwise = empty - - pp_occ = sdocOption sdocSuppressUniques $ \case - True -> text (strip_th_unique (unpackFS occ)) - False -> ftext occ - - -- See Note [Suppressing uniques in OccNames] - strip_th_unique ('[' : c : _) | isAlphaNum c = [] - strip_th_unique (c : cs) = c : strip_th_unique cs - strip_th_unique [] = [] - -{- -Note [Suppressing uniques in OccNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a hack to de-wobblify the OccNames that contain uniques from -Template Haskell that have been turned into a string in the OccName. -See Note [Unique OccNames from Template Haskell] in Convert.hs - -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - -mkOccName :: NameSpace -> String -> OccName -mkOccName occ_sp str = OccName occ_sp (mkFastString str) - -mkOccNameFS :: NameSpace -> FastString -> OccName -mkOccNameFS occ_sp fs = OccName occ_sp fs - -mkVarOcc :: String -> OccName -mkVarOcc s = mkOccName varName s - -mkVarOccFS :: FastString -> OccName -mkVarOccFS fs = mkOccNameFS varName fs - -mkDataOcc :: String -> OccName -mkDataOcc = mkOccName dataName - -mkDataOccFS :: FastString -> OccName -mkDataOccFS = mkOccNameFS dataName - -mkTyVarOcc :: String -> OccName -mkTyVarOcc = mkOccName tvName - -mkTyVarOccFS :: FastString -> OccName -mkTyVarOccFS fs = mkOccNameFS tvName fs - -mkTcOcc :: String -> OccName -mkTcOcc = mkOccName tcName - -mkTcOccFS :: FastString -> OccName -mkTcOccFS = mkOccNameFS tcName - -mkClsOcc :: String -> OccName -mkClsOcc = mkOccName clsName - -mkClsOccFS :: FastString -> OccName -mkClsOccFS = mkOccNameFS clsName - --- demoteOccName lowers the Namespace of OccName. --- see Note [Demotion] -demoteOccName :: OccName -> Maybe OccName -demoteOccName (OccName space name) = do - space' <- demoteNameSpace space - return $ OccName space' name - --- Name spaces are related if there is a chance to mean the one when one writes --- the other, i.e. variables <-> data constructors and type variables <-> type constructors -nameSpacesRelated :: NameSpace -> NameSpace -> Bool -nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 - -otherNameSpace :: NameSpace -> NameSpace -otherNameSpace VarName = DataName -otherNameSpace DataName = VarName -otherNameSpace TvName = TcClsName -otherNameSpace TcClsName = TvName - - - -{- | Other names in the compiler add additional information to an OccName. -This class provides a consistent way to access the underlying OccName. -} -class HasOccName name where - occName :: name -> OccName - -{- -************************************************************************ -* * - Environments -* * -************************************************************************ - -OccEnvs are used mainly for the envts in ModIfaces. - -Note [The Unique of an OccName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, and indeed FastStrings are allocated keys -sequentially starting at 0. - -So we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char representing the name space. This in turn makes it -easy to build an OccEnv. --} - -instance Uniquable OccName where - -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs - getUnique (OccName DataName fs) = mkDataOccUnique fs - getUnique (OccName TvName fs) = mkTvOccUnique fs - getUnique (OccName TcClsName fs) = mkTcOccUnique fs - -newtype OccEnv a = A (UniqFM a) - deriving Data - -emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a -extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a -extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a -lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -occEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a -delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt -alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt - -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -occEnvElts (A x) = eltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y -alterOccEnv fn (A y) k = A $ alterUFM fn y k - -instance Outputable a => Outputable (OccEnv a) where - ppr x = pprOccEnv ppr x - -pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc -pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env - -type OccSet = UniqSet OccName - -emptyOccSet :: OccSet -unitOccSet :: OccName -> OccSet -mkOccSet :: [OccName] -> OccSet -extendOccSet :: OccSet -> OccName -> OccSet -extendOccSetList :: OccSet -> [OccName] -> OccSet -unionOccSets :: OccSet -> OccSet -> OccSet -unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet -elemOccSet :: OccName -> OccSet -> Bool -isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -intersectsOccSet :: OccSet -> OccSet -> Bool -filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet - -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) -filterOccSet = filterUniqSet - -{- -************************************************************************ -* * -\subsection{Predicates and taking them apart} -* * -************************************************************************ --} - -occNameString :: OccName -> String -occNameString (OccName _ s) = unpackFS s - -setOccNameSpace :: NameSpace -> OccName -> OccName -setOccNameSpace sp (OccName _ occ) = OccName sp occ - -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool - -isVarOcc (OccName VarName _) = True -isVarOcc _ = False - -isTvOcc (OccName TvName _) = True -isTvOcc _ = False - -isTcOcc (OccName TcClsName _) = True -isTcOcc _ = False - --- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces -isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False - -isDataOcc (OccName DataName _) = True -isDataOcc _ = False - --- | Test if the 'OccName' is a data constructor that starts with --- a symbol (e.g. @:@, or @[]@) -isDataSymOcc :: OccName -> Bool -isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc _ = False --- Pretty inefficient! - --- | Test if the 'OccName' is that for any operator (whether --- it is a data constructor or variable or whatever) -isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s --- Pretty inefficient! - -parenSymOcc :: OccName -> SDoc -> SDoc --- ^ Wrap parens around an operator -parenSymOcc occ doc | isSymOcc occ = parens doc - | otherwise = doc - -startsWithUnderscore :: OccName -> Bool --- ^ Haskell 98 encourages compilers to suppress warnings about unused --- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = headFS (occNameFS occ) == '_' - -{- -************************************************************************ -* * -\subsection{Making system names} -* * -************************************************************************ - -Here's our convention for splitting up the interface file name space: - - d... dictionary identifiers - (local variables, so no name-clash worries) - -All of these other OccNames contain a mixture of alphabetic -and symbolic characters, and hence cannot possibly clash with -a user-written type or function name - - $f... Dict-fun identifiers (from inst decls) - $dmop Default method for 'op' - $pnC n'th superclass selector for class C - $wf Worker for function 'f' - $sf.. Specialised version of f - D:C Data constructor for dictionary for class C - NTCo:T Coercion connecting newtype T with its representation type - TFCo:R Coercion connecting a data family to its representation type R - -In encoded form these appear as Zdfxxx etc - - :... keywords (export:, letrec: etc.) ---- I THINK THIS IS WRONG! - -This knowledge is encoded in the following functions. - -@mk_deriv@ generates an @OccName@ from the prefix and a string. -NB: The string must already be encoded! --} - --- | Build an 'OccName' derived from another 'OccName'. --- --- Note that the pieces of the name are passed in as a @[FastString]@ so that --- the whole name can be constructed with a single 'concatFS', minimizing --- unnecessary intermediate allocations. -mk_deriv :: NameSpace - -> FastString -- ^ A prefix which distinguishes one sort of - -- derived name from another - -> [FastString] -- ^ The name we are deriving from in pieces which - -- will be concatenated. - -> OccName -mk_deriv occ_sp sys_prefix str = - mkOccNameFS occ_sp (concatFS $ sys_prefix : str) - -isDerivedOccName :: OccName -> Bool --- ^ Test for definitions internally generated by GHC. This predicate --- is used to suppress printing of internal definitions in some debug prints -isDerivedOccName occ = - case occNameString occ of - '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo - c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions - _other -> False - -isDefaultMethodOcc :: OccName -> Bool -isDefaultMethodOcc occ = - case occNameString occ of - '$':'d':'m':_ -> True - _ -> False - --- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? --- This is needed as these bindings are renamed differently. --- See Note [Grand plan for Typeable] in TcTypeable. -isTypeableBindOcc :: OccName -> Bool -isTypeableBindOcc occ = - case occNameString occ of - '$':'t':'c':_ -> True -- mkTyConRepOcc - '$':'t':'r':_ -> True -- Module binding - _ -> False - -mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, - mkClassDataConOcc, mkDictOcc, - mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkTyConRepOcc - :: OccName -> OccName - --- These derived variables have a prefix that no Haskell value could have -mkDataConWrapperOcc = mk_simple_deriv varName "$W" -mkWorkerOcc = mk_simple_deriv varName "$w" -mkMatcherOcc = mk_simple_deriv varName "$m" -mkBuilderOcc = mk_simple_deriv varName "$b" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkClassOpAuxOcc = mk_simple_deriv varName "$c" -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" -mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible -mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class -mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" - --- Used in derived instances -mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" -mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" -mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" - --- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable -mkTyConRepOcc occ = mk_simple_deriv varName prefix occ - where - prefix | isDataOcc occ = "$tc'" - | otherwise = "$tc" - --- Generic deriving mechanism -mkGenR = mk_simple_deriv tcName "Rep_" -mkGen1R = mk_simple_deriv tcName "Rep1_" - --- Overloaded record field selectors -mkRecFldSelOcc :: String -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] - -mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName -mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] - --- Data constructor workers are made by setting the name space --- of the data constructor OccName (which should be a DataName) --- to VarName -mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ - -mkSuperDictAuxOcc :: Int -> OccName -> OccName -mkSuperDictAuxOcc index cls_tc_occ - = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] - -mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 - -> OccName -- ^ Class, e.g. @Ord@ - -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -mkSuperDictSelOcc index cls_tc_occ - = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] - -mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' - -> OccName -- ^ Local name, e.g. @sat@ - -> OccName -- ^ Nice unique version, e.g. @$L23sat@ -mkLocalOcc uniq occ - = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] - -- The Unique might print with characters - -- that need encoding (e.g. 'z'!) - --- | Derive a name for the representation type constructor of a --- @data@\/@newtype@ instance. -mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ @R:Map@ -mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) - -mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. - -- Only used in debug mode, for extra clarity - -> Bool -- ^ Is this a hs-boot instance DFun? - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ - --- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real --- thing when we compile the mother module. Reason: we don't know exactly --- what the mother module will call it. - -mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set - where - prefix | is_boot = "$fx" - | otherwise = "$f" - -mkDataTOcc, mkDataCOcc - :: OccName -- ^ TyCon or data con string - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ --- data T = MkT ... deriving( Data ) needs definitions for --- $tT :: Data.Generics.Basics.DataType --- $cMkT :: Data.Generics.Basics.Constr -mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) -mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) - -{- -Sometimes we need to pick an OccName that has not already been used, -given a set of in-use OccNames. --} - -chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName -chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) - where - loop occ n - | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) - | otherwise = occ - -{- -We used to add a '$m' to indicate a method, but that gives rise to bad -error messages from the type checker when we print the function name or pattern -of an instance-decl binding. Why? Because the binding is zapped -to use the method name in place of the selector name. -(See TcClassDcl.tcMethodBind) - -The way it is now, -ddump-xx output may look confusing, but -you can always say -dppr-debug to get the uniques. - -However, we *do* have to zap the first character to be lower case, -because overloaded constructors (blarg) generate methods too. -And convert to VarName space - -e.g. a call to constructor MkFoo where - data (Ord a) => Foo a = MkFoo a - -If this is necessary, we do it by prefixing '$m'. These -guys never show up in error messages. What a hack. --} - -mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ -mkMethodOcc occ = mk_simple_deriv varName "$m" occ - -{- -************************************************************************ -* * -\subsection{Tidying them up} -* * -************************************************************************ - -Before we print chunks of code we like to rename it so that -we don't have to print lots of silly uniques in it. But we mustn't -accidentally introduce name clashes! So the idea is that we leave the -OccName alone unless it accidentally clashes with one that is already -in scope; if so, we tack on '1' at the end and try again, then '2', and -so on till we find a unique one. - -There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' -because that isn't a single lexeme. So we encode it to 'lle' and *then* -tack on the '1', if necessary. - -Note [TidyOccEnv] -~~~~~~~~~~~~~~~~~ -type TidyOccEnv = UniqFM Int - -* Domain = The OccName's FastString. These FastStrings are "taken"; - make sure that we don't re-use - -* Int, n = A plausible starting point for new guesses - There is no guarantee that "FSn" is available; - you must look that up in the TidyOccEnv. But - it's a good place to start looking. - -* When looking for a renaming for "foo2" we strip off the "2" and start - with "foo". Otherwise if we tidy twice we get silly names like foo23. - - However, if it started with digits at the end, we always make a name - with digits at the end, rather than shortening "foo2" to just "foo", - even if "foo" is unused. Reasons: - - Plain "foo" might be used later - - We use trailing digits to subtly indicate a unification variable - in typechecker error message; see TypeRep.tidyTyVarBndr - -We have to take care though! Consider a machine-generated module (#10370) - module Foo where - a1 = e1 - a2 = e2 - ... - a2000 = e2000 -Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, -we have to do a linear search to find a free one, "a2001". That might just be -acceptable once. But if we now come across "a8" again, we don't want to repeat -that search. - -So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for -starting the search; and we make sure to update the starting point for "a" -after we allocate a new one. - - -Note [Tidying multiple names at once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider - - > :t (id,id,id) - -Every id contributes a type variable to the type signature, and all of them are -"a". If we tidy them one by one, we get - - (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) - -which is a bit unfortunate, as it unfairly renames only two of them. What we -would like to see is - - (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) - -To achieve this, the function avoidClashesOccEnv can be used to prepare the -TidyEnv, by “blocking” every name that occurs twice in the map. This way, none -of the "a"s will get the privilege of keeping this name, and all of them will -get a suitable number by tidyOccName. - -This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs -for an example where this is used. - -This is #12382. - --} - -type TidyOccEnv = UniqFM Int -- The in-scope OccNames - -- See Note [TidyOccEnv] - -emptyTidyOccEnv :: TidyOccEnv -emptyTidyOccEnv = emptyUFM - -initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl' add emptyUFM - where - add env (OccName _ fs) = addToUFM env fs 1 - -delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv -delTidyOccEnvList = delListFromUFM - --- see Note [Tidying multiple names at once] -avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv -avoidClashesOccEnv env occs = go env emptyUFM occs - where - go env _ [] = env - go env seenOnce ((OccName _ fs):occs) - | fs `elemUFM` env = go env seenOnce occs - | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs - | otherwise = go env (addToUFM seenOnce fs ()) occs - -tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) -tidyOccName env occ@(OccName occ_sp fs) - | not (fs `elemUFM` env) - = -- Desired OccName is free, so use it, - -- and record in 'env' that it's no longer available - (addToUFM env fs 1, occ) - - | otherwise - = case lookupUFM env base1 of - Nothing -> (addToUFM env base1 2, OccName occ_sp base1) - Just n -> find 1 n - where - base :: String -- Drop trailing digits (see Note [TidyOccEnv]) - base = dropWhileEndLE isDigit (unpackFS fs) - base1 = mkFastString (base ++ "1") - - find !k !n - = case lookupUFM env new_fs of - Just {} -> find (k+1 :: Int) (n+k) - -- By using n+k, the n argument to find goes - -- 1, add 1, add 2, add 3, etc which - -- moves at quadratic speed through a dense patch - - Nothing -> (new_env, OccName occ_sp new_fs) - where - new_fs = mkFastString (base ++ show n) - new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) - -- Update: base1, so that next time we'll start where we left off - -- new_fs, so that we know it is taken - -- If they are the same (n==1), the former wins - -- See Note [TidyOccEnv] - - -{- -************************************************************************ -* * - Binary instance - Here rather than in GHC.Iface.Binary because OccName is abstract -* * -************************************************************************ --} - -instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 - put_ bh DataName = do - putByte bh 1 - put_ bh TvName = do - putByte bh 2 - put_ bh TcClsName = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName - -instance Binary OccName where - put_ bh (OccName aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (OccName aa ab) diff --git a/compiler/basicTypes/OccName.hs-boot b/compiler/basicTypes/OccName.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/OccName.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module OccName where - -import GhcPrelude () - -data OccName diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs deleted file mode 100644 --- a/compiler/basicTypes/PatSyn.hs +++ /dev/null @@ -1,484 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[PatSyn]{@PatSyn@: Pattern synonyms} --} - -{-# LANGUAGE CPP #-} - -module PatSyn ( - -- * Main data types - PatSyn, mkPatSyn, - - -- ** Type deconstruction - patSynName, patSynArity, patSynIsInfix, - patSynArgs, - patSynMatcher, patSynBuilder, - patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, - patSynInstArgTys, patSynInstResTy, patSynFieldLabels, - patSynFieldType, - - updatePatSynIds, pprPatSynType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Type -import TyCoPpr -import Name -import Outputable -import Unique -import Util -import BasicTypes -import Var -import FieldLabel - -import qualified Data.Data as Data -import Data.Function -import Data.List (find) - -{- -************************************************************************ -* * -\subsection{Pattern synonyms} -* * -************************************************************************ --} - --- | Pattern Synonym --- --- See Note [Pattern synonym representation] --- See Note [Pattern synonym signature contexts] -data PatSyn - = MkPatSyn { - psName :: Name, - psUnique :: Unique, -- Cached from Name - - psArgs :: [Type], - psArity :: Arity, -- == length psArgs - psInfix :: Bool, -- True <=> declared infix - psFieldLabels :: [FieldLabel], -- List of fields for a - -- record pattern synonym - -- INVARIANT: either empty if no - -- record pat syn or same length as - -- psArgs - - -- Universally-quantified type variables - psUnivTyVars :: [TyVarBinder], - - -- Required dictionaries (may mention psUnivTyVars) - psReqTheta :: ThetaType, - - -- Existentially-quantified type vars - psExTyVars :: [TyVarBinder], - - -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) - psProvTheta :: ThetaType, - - -- Result type - psResultTy :: Type, -- Mentions only psUnivTyVars - -- See Note [Pattern synonym result type] - - -- See Note [Matchers and builders for pattern synonyms] - psMatcher :: (Id, Bool), - -- Matcher function. - -- If Bool is True then prov_theta and arg_tys are empty - -- and type is - -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. Void# -> r) - -- -> (Void# -> r) - -- -> r - -- - -- Otherwise type is - -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. prov_theta => arg_tys -> r) - -- -> (Void# -> r) - -- -> r - - psBuilder :: Maybe (Id, Bool) - -- Nothing => uni-directional pattern synonym - -- Just (builder, is_unlifted) => bi-directional - -- Builder function, of type - -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) - -- => arg_tys -> res_ty - -- See Note [Builder for pattern synonyms with unboxed type] - } - -{- Note [Pattern synonym signature contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a pattern synonym signature we write - pattern P :: req => prov => t1 -> ... tn -> res_ty - -Note that the "required" context comes first, then the "provided" -context. Moreover, the "required" context must not mention -existentially-bound type variables; that is, ones not mentioned in -res_ty. See lots of discussion in #10928. - -If there is no "provided" context, you can omit it; but you -can't omit the "required" part (unless you omit both). - -Example 1: - pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) - pattern P1 x = Just (3,x) - - We require (Num a, Eq a) to match the 3; there is no provided - context. - -Example 2: - data T2 where - MkT2 :: (Num a, Eq a) => a -> a -> T2 - - pattern P2 :: () => (Num a, Eq a) => a -> T2 - pattern P2 x = MkT2 3 x - - When we match against P2 we get a Num dictionary provided. - We can use that to check the match against 3. - -Example 3: - pattern P3 :: Eq a => a -> b -> T3 b - - This signature is illegal because the (Eq a) is a required - constraint, but it mentions the existentially-bound variable 'a'. - You can see it's existential because it doesn't appear in the - result type (T3 b). - -Note [Pattern synonym result type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b = MkT b a - - pattern P :: a -> T [a] Bool - pattern P x = MkT True [x] - -P's psResultTy is (T a Bool), and it really only matches values of -type (T [a] Bool). For example, this is ill-typed - - f :: T p q -> String - f (P x) = "urk" - -This is different to the situation with GADTs: - - data S a where - MkS :: Int -> S Bool - -Now MkS (and pattern synonyms coming from MkS) can match a -value of type (S a), not just (S Bool); we get type refinement. - -That in turn means that if you have a pattern - - P x :: T [ty] Bool - -it's not entirely straightforward to work out the instantiation of -P's universal tyvars. You have to /match/ - the type of the pattern, (T [ty] Bool) -against - the psResultTy for the pattern synonym, T [a] Bool -to get the instantiation a := ty. - -This is very unlike DataCons, where univ tyvars match 1-1 the -arguments of the TyCon. - -Side note: I (SG) get the impression that instantiated return types should -generate a *required* constraint for pattern synonyms, rather than a *provided* -constraint like it's the case for GADTs. For example, I'd expect these -declarations to have identical semantics: - - pattern Just42 :: Maybe Int - pattern Just42 = Just 42 - - pattern Just'42 :: (a ~ Int) => Maybe a - pattern Just'42 = Just 42 - -The latter generates the proper required constraint, the former does not. -Also rather different to GADTs is the fact that Just42 doesn't have any -universally quantified type variables, whereas Just'42 or MkS above has. - -Note [Pattern synonym representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym declaration - - pattern P x = MkT [x] (Just 42) - -where - data T a where - MkT :: (Show a, Ord b) => [b] -> a -> T a - -so pattern P has type - - b -> T (Maybe t) - -with the following typeclass constraints: - - requires: (Eq t, Num t) - provides: (Show (Maybe t), Ord b) - -In this case, the fields of MkPatSyn will be set as follows: - - psArgs = [b] - psArity = 1 - psInfix = False - - psUnivTyVars = [t] - psExTyVars = [b] - psProvTheta = (Show (Maybe t), Ord b) - psReqTheta = (Eq t, Num t) - psResultTy = T (Maybe t) - -Note [Matchers and builders for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For each pattern synonym P, we generate - - * a "matcher" function, used to desugar uses of P in patterns, - which implements pattern matching - - * A "builder" function (for bidirectional pattern synonyms only), - used to desugar uses of P in expressions, which constructs P-values. - -For the above example, the matcher function has type: - - $mP :: forall (r :: ?) t. (Eq t, Num t) - => T (Maybe t) - -> (forall b. (Show (Maybe t), Ord b) => b -> r) - -> (Void# -> r) - -> r - -with the following implementation: - - $mP @r @t $dEq $dNum scrut cont fail - = case scrut of - MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x - _ -> fail Void# - -Notice that the return type 'r' has an open kind, so that it can -be instantiated by an unboxed type; for example where we see - f (P x) = 3# - -The extra Void# argument for the failure continuation is needed so that -it is lazy even when the result type is unboxed. - -For the same reason, if the pattern has no arguments, an extra Void# -argument is added to the success continuation as well. - -For *bidirectional* pattern synonyms, we also generate a "builder" -function which implements the pattern synonym in an expression -context. For our running example, it will be: - - $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) - => b -> T (Maybe t) - $bP x = MkT [x] (Just 42) - -NB: the existential/universal and required/provided split does not -apply to the builder since you are only putting stuff in, not getting -stuff out. - -Injectivity of bidirectional pattern synonyms is checked in -tcPatToExpr which walks the pattern and returns its corresponding -expression when available. - -Note [Builder for pattern synonyms with unboxed type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For bidirectional pattern synonyms that have no arguments and have an -unboxed type, we add an extra Void# argument to the builder, else it -would be a top-level declaration with an unboxed type. - - pattern P = 0# - - $bP :: Void# -> Int# - $bP _ = 0# - -This means that when typechecking an occurrence of P in an expression, -we must remember that the builder has this void argument. This is -done by TcPatSyn.patSynBuilderOcc. - -Note [Pattern synonyms and the data type Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type of a pattern synonym is of the form (See Note -[Pattern synonym signatures] in TcSigs): - - forall univ_tvs. req => forall ex_tvs. prov => ... - -We cannot in general represent this by a value of type Type: - - - if ex_tvs is empty, then req and prov cannot be distinguished from - each other - - if req is empty, then univ_tvs and ex_tvs cannot be distinguished - from each other, and moreover, prov is seen as the "required" context - (as it is the only context) - - -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq PatSyn where - (==) = (==) `on` getUnique - (/=) = (/=) `on` getUnique - -instance Uniquable PatSyn where - getUnique = psUnique - -instance NamedThing PatSyn where - getName = patSynName - -instance Outputable PatSyn where - ppr = ppr . getName - -instance OutputableBndr PatSyn where - pprInfixOcc = pprInfixName . getName - pprPrefixOcc = pprPrefixName . getName - -instance Data.Data PatSyn where - -- don't traverse? - toConstr _ = abstractConstr "PatSyn" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "PatSyn" - -{- -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - --- | Build a new pattern synonym -mkPatSyn :: Name - -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type - -- variables and required dicts - -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type - -- variables and provided dicts - -> [Type] -- ^ Original arguments - -> Type -- ^ Original result type - -> (Id, Bool) -- ^ Name of matcher - -> Maybe (Id, Bool) -- ^ Name of builder - -> [FieldLabel] -- ^ Names of fields for - -- a record pattern synonym - -> PatSyn - -- NB: The univ and ex vars are both in TyBinder form and TyVar form for - -- convenience. All the TyBinders should be Named! -mkPatSyn name declared_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - orig_args - orig_res_ty - matcher builder field_labels - = MkPatSyn {psName = name, psUnique = getUnique name, - psUnivTyVars = univ_tvs, - psExTyVars = ex_tvs, - psProvTheta = prov_theta, psReqTheta = req_theta, - psInfix = declared_infix, - psArgs = orig_args, - psArity = length orig_args, - psResultTy = orig_res_ty, - psMatcher = matcher, - psBuilder = builder, - psFieldLabels = field_labels - } - --- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification -patSynName :: PatSyn -> Name -patSynName = psName - --- | Should the 'PatSyn' be presented infix? -patSynIsInfix :: PatSyn -> Bool -patSynIsInfix = psInfix - --- | Arity of the pattern synonym -patSynArity :: PatSyn -> Arity -patSynArity = psArity - -patSynArgs :: PatSyn -> [Type] -patSynArgs = psArgs - -patSynFieldLabels :: PatSyn -> [FieldLabel] -patSynFieldLabels = psFieldLabels - --- | Extract the type for any given labelled field of the 'DataCon' -patSynFieldType :: PatSyn -> FieldLabelString -> Type -patSynFieldType ps label - = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of - Just (_, ty) -> ty - Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) - -patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] -patSynUnivTyVarBinders = psUnivTyVars - -patSynExTyVars :: PatSyn -> [TyVar] -patSynExTyVars ps = binderVars (psExTyVars ps) - -patSynExTyVarBinders :: PatSyn -> [TyVarBinder] -patSynExTyVarBinders = psExTyVars - -patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs - , psProvTheta = prov, psReqTheta = req - , psArgs = arg_tys, psResultTy = res_ty }) - = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) - -patSynMatcher :: PatSyn -> (Id,Bool) -patSynMatcher = psMatcher - -patSynBuilder :: PatSyn -> Maybe (Id, Bool) -patSynBuilder = psBuilder - -updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn -updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) - = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } - where - tidy_pr (id, dummy) = (tidy_fn id, dummy) - -patSynInstArgTys :: PatSyn -> [Type] -> [Type] --- Return the types of the argument patterns --- e.g. data D a = forall b. MkD a b (b->a) --- pattern P f x y = MkD (x,True) y f --- D :: forall a. forall b. a -> b -> (b->a) -> D a --- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c --- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] --- NB: the inst_tys should be both universal and existential -patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psExTyVars = ex_tvs, psArgs = arg_tys }) - inst_tys - = ASSERT2( tyvars `equalLength` inst_tys - , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = binderVars (univ_tvs ++ ex_tvs) - -patSynInstResTy :: PatSyn -> [Type] -> Type --- Return the type of whole pattern --- E.g. pattern P x y = Just (x,x,y) --- P :: a -> b -> Just (a,a,b) --- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) --- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars -patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psResultTy = res_ty }) - inst_tys - = ASSERT2( univ_tvs `equalLength` inst_tys - , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) - substTyWith (binderVars univ_tvs) inst_tys res_ty - --- | Print the type of a pattern synonym. The foralls are printed explicitly -pprPatSynType :: PatSyn -> SDoc -pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta - , psExTyVars = ex_tvs, psProvTheta = prov_theta - , psArgs = orig_args, psResultTy = orig_res_ty }) - = sep [ pprForAll univ_tvs - , pprThetaArrowTy req_theta - , ppWhen insert_empty_ctxt $ parens empty <+> darrow - , pprType sigma_ty ] - where - sigma_ty = mkForAllTys ex_tvs $ - mkInvisFunTys prov_theta $ - mkVisFunTys orig_args orig_res_ty - insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/basicTypes/PatSyn.hs-boot b/compiler/basicTypes/PatSyn.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/PatSyn.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ -module PatSyn where - -import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep (Type) -import Var (TyVar) -import Name (Name) - -data PatSyn - -patSynArity :: PatSyn -> Arity -patSynInstArgTys :: PatSyn -> [Type] -> [Type] -patSynExTyVars :: PatSyn -> [TyVar] -patSynName :: PatSyn -> Name diff --git a/compiler/basicTypes/Predicate.hs b/compiler/basicTypes/Predicate.hs deleted file mode 100644 --- a/compiler/basicTypes/Predicate.hs +++ /dev/null @@ -1,228 +0,0 @@ -{- - -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 [TyVar] [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) <- splitForAllTys 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) diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs deleted file mode 100644 --- a/compiler/basicTypes/RdrName.hs +++ /dev/null @@ -1,1387 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName' is the type of names that come directly from the parser. They --- have not yet had their scoping and binding resolved by the renamer and can be --- thought of to a first approximation as an 'OccName.OccName' with an optional module --- qualifier --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module RdrName ( - -- * The main type - RdrName(..), -- Constructors exported only to GHC.Iface.Binary - - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, - - -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, - elemLocalRdrEnv, inLocalRdrEnvScope, - localRdrEnvElts, delLocalRdrEnvList, - - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, - lookupGRE_Name_OccName, - getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, - - -- * GlobalRdrElts - gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, - greRdrNames, greSrcSpan, greQualModName, - gresToAvailInfo, - - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel, - unQualOK, qualSpecOK, unQualSpecOK, - pprNameProvenance, - Parent(..), greParent_maybe, - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport, - - -- * Utils for StarIsType - starInfo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Module -import Name -import Avail -import NameSet -import Maybes -import SrcLoc -import FastString -import FieldLabel -import Outputable -import Unique -import UniqFM -import UniqSet -import Util -import NameEnv - -import Data.Data -import Data.List( sortBy ) - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, --- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, --- 'ApiAnnotation.AnnBackquote' @'`'@, --- 'ApiAnnotation.AnnVal' --- 'ApiAnnotation.AnnTilde', - --- For details on above see note [Api annotations] in ApiAnnotation -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Simple functions} -* * -************************************************************************ --} - -instance HasOccName RdrName where - occName = rdrNameOcc - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrNameSpace :: RdrName -> NameSpace -rdrNameSpace = occNameSpace . rdrNameOcc - --- demoteRdrName lowers the NameSpace of RdrName. --- see Note [Demotion] in OccName -demoteRdrName :: RdrName -> Maybe RdrName -demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) -demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) -demoteRdrName (Orig _ _) = panic "demoteRdrName" -demoteRdrName (Exact _) = panic "demoteRdrName" - - -- These two are the basic constructors -mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = Unqual occ - -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = Qual mod occ - -mkOrig :: Module -> OccName -> RdrName -mkOrig mod occ = Orig mod occ - ---------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FastString -> RdrName -mkUnqual sp n = Unqual (mkOccNameFS sp n) - -mkVarUnqual :: FastString -> RdrName -mkVarUnqual n = Unqual (mkVarOccFS n) - --- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and --- the 'OccName' are taken from the first and second elements of the tuple respectively -mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) - -getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = nameRdrName (getName name) - -nameRdrName :: Name -> RdrName -nameRdrName name = Exact name --- Keep the Name even for Internal names, so that the --- unique is still there for debug printing, particularly --- of Types (which are converted to IfaceTypes before printing) - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -isRdrDataCon :: RdrName -> Bool -isRdrTyVar :: RdrName -> Bool -isRdrTc :: RdrName -> Bool - -isRdrDataCon rn = isDataOcc (rdrNameOcc rn) -isRdrTyVar rn = isTvOcc (rdrNameOcc rn) -isRdrTc rn = isTcOcc (rdrNameOcc rn) - -isSrcRdrName :: RdrName -> Bool -isSrcRdrName (Unqual _) = True -isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False - -isUnqual :: RdrName -> Bool -isUnqual (Unqual _) = True -isUnqual _ = False - -isQual :: RdrName -> Bool -isQual (Qual _ _) = True -isQual _ = False - -isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) -isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing - -isOrig :: RdrName -> Bool -isOrig (Orig _ _) = True -isOrig _ = False - -isOrig_maybe :: RdrName -> Maybe (Module, OccName) -isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing - -isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Orig _ _) _ = GT - -{- -************************************************************************ -* * - LocalRdrEnv -* * -************************************************************************ --} - --- | Local Reader Environment --- --- This environment is used to store local bindings --- (@let@, @where@, lambda, @case@). --- It is keyed by OccName, because we never use it for qualified names --- We keep the current mapping, *and* the set of all Names in scope --- Reason: see Note [Splicing Exact names] in GHC.Rename.Env -data LocalRdrEnv = LRE { lre_env :: OccEnv Name - , lre_in_scope :: NameSet } - -instance Outputable LocalRdrEnv where - ppr (LRE {lre_env = env, lre_in_scope = ns}) - = hang (text "LocalRdrEnv {") - 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env - , text "in_scope =" - <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) - ] <+> char '}') - where - ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name - -- So we can see if the keys line up correctly - -emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv - , lre_in_scope = emptyNameSet } - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv --- The Name should be a non-top-level thing -extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name - = WARN( isExternalName name, ppr name ) - lre { lre_env = extendOccEnv env (nameOccName name) name - , lre_in_scope = extendNameSet ns name } - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names - = WARN( any isExternalName names, ppr names ) - lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] - , lre_in_scope = extendNameSetList ns names } - -lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr - | Unqual occ <- rdr - = lookupOccEnv env occ - - -- See Note [Local bindings with Exact Names] - | Exact name <- rdr - , name `elemNameSet` ns - = Just name - - | otherwise - = Nothing - -lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ - -elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) - = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] - Qual {} -> False - Orig {} -> False - -localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env - -inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool --- This is the point of the NameSet -inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns - -delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv -delLocalRdrEnvList lre@(LRE { lre_env = env }) occs - = lre { lre_env = delListFromOccEnv env occs } - -{- -Note [Local bindings with Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Template Haskell we can make local bindings that have Exact Names. -Computing shadowing etc may use elemLocalRdrEnv (at least it certainly -does so in GHC.Rename.Types.bindHsQTyVars), so for an Exact Name we must consult -the in-scope-name-set. - - -************************************************************************ -* * - GlobalRdrEnv -* * -************************************************************************ --} - --- | Global Reader Environment -type GlobalRdrEnv = OccEnv [GlobalRdrElt] --- ^ Keyed by 'OccName'; when looking up a qualified name --- we look up the 'OccName' part, and then check the 'Provenance' --- to see if the appropriate qualification is valid. This --- saves routinely doubling the size of the env by adding both --- qualified and unqualified names to the domain. --- --- The list in the codomain is required because there may be name clashes --- These only get reported on lookup, not on construction --- --- INVARIANT 1: All the members of the list have distinct --- 'gre_name' fields; that is, no duplicate Names --- --- INVARIANT 2: Imported provenance => Name is an ExternalName --- However LocalDefs can have an InternalName. This --- happens only when type-checking a [d| ... |] Template --- Haskell quotation; see this note in GHC.Rename.Names --- Note [Top-level Names in Template Haskell decl quotes] --- --- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then --- greOccName gre = occ --- --- NB: greOccName gre is usually the same as --- nameOccName (gre_name gre), but not always in the --- case of record selectors; see greOccName - --- | Global Reader Element --- --- An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: Name - , gre_par :: Parent - , gre_lcl :: Bool -- ^ True <=> the thing was defined locally - , gre_imp :: [ImportSpec] -- ^ In scope through these imports - } deriving (Data, Eq) - -- INVARIANT: either gre_lcl = True or gre_imp is non-empty - -- See Note [GlobalRdrElt provenance] - --- | The children of a Name are the things that are abbreviated by the ".." --- notation in export lists. See Note [Parents] -data Parent = NoParent - | ParentIs { par_is :: Name } - | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } - -- ^ See Note [Parents for record fields] - deriving (Eq, Data) - -instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = text "parent:" <> ppr n - ppr (FldParent n f) = text "fldparent:" - <> ppr n <> colon <> ppr f - -plusParent :: Parent -> Parent -> Parent --- See Note [Combining parents] -plusParent p1@(ParentIs _) p2 = hasParent p1 p2 -plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 -plusParent p1 p2@(ParentIs _) = hasParent p2 p1 -plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 -plusParent _ _ = NoParent - -hasParent :: Parent -> Parent -> Parent -#if defined(DEBUG) -hasParent p NoParent = p -hasParent p p' - | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree -#endif -hasParent p _ = p - - -{- Note [GlobalRdrElt provenance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", -i.e. how the Name came to be in scope. It can be in scope two ways: - - gre_lcl = True: it is bound in this module - - gre_imp: a list of all the imports that brought it into scope - -It's an INVARIANT that you have one or the other; that is, either -gre_lcl is True, or gre_imp is non-empty. - -It is just possible to have *both* if there is a module loop: a Name -is defined locally in A, and also brought into scope by importing a -module that SOURCE-imported A. Example (#7672): - - A.hs-boot module A where - data T - - B.hs module B(Decl.T) where - import {-# SOURCE #-} qualified A as Decl - - A.hs module A where - import qualified B - data T = Z | S B.T - -In A.hs, 'T' is locally bound, *and* imported as B.T. - -Note [Parents] -~~~~~~~~~~~~~~~~~ - Parent Children -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - data T Data constructors - Record-field ids - - data family T Data constructors and record-field ids - of all visible data instances of T - - class C Class operations - Associated type constructors - -~~~~~~~~~~~~~~~~~~~~~~~~~ - Constructor Meaning - ~~~~~~~~~~~~~~~~~~~~~~~~ - NoParent Can not be bundled with a type constructor. - ParentIs n Can be bundled with the type constructor corresponding to - n. - FldParent See Note [Parents for record fields] - - - - -Note [Parents for record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record fields, in addition to the Name of the type constructor -(stored in par_is), we use FldParent to store the field label. This -extra information is used for identifying overloaded record fields -during renaming. - -In a definition arising from a normal module (without --XDuplicateRecordFields), par_lbl will be Nothing, meaning that the -field's label is the same as the OccName of the selector's Name. The -GlobalRdrEnv will contain an entry like this: - - "x" |-> GRE x (FldParent T Nothing) LocalDef - -When -XDuplicateRecordFields is enabled for the module that contains -T, the selector's Name will be mangled (see comments in FieldLabel). -Thus we store the actual field label in par_lbl, and the GlobalRdrEnv -entry looks like this: - - "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef - -Note that the OccName used when adding a GRE to the environment -(greOccName) now depends on the parent field: for FldParent it is the -field label, if present, rather than the selector name. - -~~ - -Record pattern synonym selectors are treated differently. Their parent -information is `NoParent` in the module in which they are defined. This is because -a pattern synonym `P` has no parent constructor either. - -However, if `f` is bundled with a type constructor `T` then whenever `f` is -imported the parent will use the `Parent` constructor so the parent of `f` is -now `T`. - - -Note [Combining parents] -~~~~~~~~~~~~~~~~~~~~~~~~ -With an associated type we might have - module M where - class C a where - data T a - op :: T a -> a - instance C Int where - data T Int = TInt - instance C Bool where - data T Bool = TBool - -Then: C is the parent of T - T is the parent of TInt and TBool -So: in an export list - C(..) is short for C( op, T ) - T(..) is short for T( TInt, TBool ) - -Module M exports everything, so its exports will be - AvailTC C [C,T,op] - AvailTC T [T,TInt,TBool] -On import we convert to GlobalRdrElt and then combine -those. For T that will mean we have - one GRE with Parent C - one GRE with NoParent -That's why plusParent picks the "best" case. --} - --- | make a 'GlobalRdrEnv' where all the elements point to the same --- Provenance (useful for "hiding" imports, or imports with no details). -gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] --- prov = Nothing => locally bound --- Just spec => imported as described by spec -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] --- Turn an Avail into a list of LocalDef GlobalRdrElts -localGREsFromAvail = gresFromAvail (const Nothing) - -gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) - where - mk_gre n - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = [is] } - - mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = n }) - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = False, gre_imp = [is] } - where - mb_lbl | is_overloaded = Just lbl - | otherwise = Nothing - - -greQualModName :: GlobalRdrElt -> ModuleName --- Get a suitable module qualifier for the GRE --- (used in mkPrintUnqualified) --- Prerecondition: the gre_name is always External -greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - | lcl, Just mod <- nameModule_maybe name = moduleName mod - | (is:_) <- iss = is_as (is_decl is) - | otherwise = pprPanic "greQualModName" (ppr gre) - -greRdrNames :: GlobalRdrElt -> [RdrName] -greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } - = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) - where - occ = greOccName gre - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- the SrcSpan that pprNameProvenance prints out depends on whether --- the Name is defined locally or not: for a local definition the --- definition site is used, otherwise the location of the import --- declaration. We want to sort the export locations in --- exportClashErr by this SrcSpan, we need to extract it: -greSrcSpan :: GlobalRdrElt -> SrcSpan -greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) - | lcl = nameSrcSpan name - | (is:_) <- iss = is_dloc (is_decl is) - | otherwise = pprPanic "greSrcSpan" (ppr gre) - -mkParent :: Name -> AvailInfo -> Parent -mkParent _ (Avail _) = NoParent -mkParent n (AvailTC m _ _) | n == m = NoParent - | otherwise = ParentIs m - -greParent_maybe :: GlobalRdrElt -> Maybe Name -greParent_maybe gre = case gre_par gre of - NoParent -> Nothing - ParentIs n -> Just n - FldParent n _ -> Just n - --- | Takes a list of distinct GREs and folds them --- into AvailInfos. This is more efficient than mapping each individual --- GRE to an AvailInfo and the folding using `plusAvail` but needs the --- uniqueness assumption. -gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] -gresToAvailInfo gres - = nameEnvElts avail_env - where - avail_env :: NameEnv AvailInfo -- Keyed by the parent - (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres - - add :: (NameEnv AvailInfo, NameSet) - -> GlobalRdrElt - -> (NameEnv AvailInfo, NameSet) - add (env, done) gre - | name `elemNameSet` done - = (env, done) -- Don't insert twice into the AvailInfo - | otherwise - = ( extendNameEnv_Acc comb availFromGRE env key gre - , done `extendNameSet` name ) - where - name = gre_name gre - key = case greParent_maybe gre of - Just parent -> parent - Nothing -> gre_name gre - - -- We want to insert the child `k` into a list of children but - -- need to maintain the invariant that the parent is first. - -- - -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] - insertChildIntoChildren _ [] k = [k] - insertChildIntoChildren p (n:ns) k - | p == k = k:n:ns - | otherwise = n:k:ns - - comb :: GlobalRdrElt -> AvailInfo -> AvailInfo - comb _ (Avail n) = Avail n -- Duplicated name, should not happen - comb gre (AvailTC m ns fls) - = case gre_par gre of - NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls - FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) - -availFromGRE :: GlobalRdrElt -> AvailInfo -availFromGRE (GRE { gre_name = me, gre_par = parent }) - = case parent of - ParentIs p -> AvailTC p [me] [] - NoParent | isTyConName me -> AvailTC me [me] [] - | otherwise -> avail me - FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] - -mkFieldLabel :: Name -> Maybe FastString -> FieldLabel -mkFieldLabel me mb_lbl = - case mb_lbl of - Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) - , flIsOverloaded = False - , flSelector = me } - Just lbl -> FieldLabel { flLabel = lbl - , flIsOverloaded = True - , flSelector = me } - -emptyGlobalRdrEnv :: GlobalRdrEnv -emptyGlobalRdrEnv = emptyOccEnv - -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env - -instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) - 2 (pprNameProvenance gre) - -pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc -pprGlobalRdrEnv locals_only env - = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) - <+> lbrace - , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] - <+> rbrace) ] - where - remove_locals gres | locals_only = filter isLocalGRE gres - | otherwise = gres - pp [] = empty - pp gres = hang (ppr occ - <+> parens (text "unique" <+> ppr (getUnique occ)) - <> colon) - 2 (vcat (map ppr gres)) - where - occ = nameOccName (gre_name (head gres)) - -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -greOccName :: GlobalRdrElt -> OccName -greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl -greOccName gre = nameOccName (gre_name gre) - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] -lookupGRE_RdrName rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_Name env name - = lookupGRE_Name_OccName env name (nameOccName name) - -lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt --- ^ Look for a particular record field selector in the environment, where the --- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [Parents for record fields] for why this happens. -lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) - -lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' --- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [Parents for record fields]. -lookupGRE_Name_OccName env name occ - = case [ gre | gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] of - [] -> Nothing - [gre] -> Just gre - gres -> pprPanic "lookupGRE_Name_OccName" - (ppr name $$ ppr occ $$ ppr gres) - -- See INVARIANT 1 on GlobalRdrEnv - - -getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] --- Returns all the qualifiers by which 'x' is in scope --- Nothing means "the unqualified version is in scope" --- [] means the thing is not in scope at all -getGRE_NameQualifier_maybes env name - = case lookupGRE_Name env name of - Just gre -> [qualifier_maybe gre] - Nothing -> [] - where - qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) - | lcl = Nothing - | otherwise = Just $ map (is_as . is_decl) iss - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_lcl = lcl }) = lcl - -isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE (GRE {gre_par = FldParent{}}) = True -isRecFldGRE _ = False - --- Returns the field label of this GRE, if it has one -greLabel :: GlobalRdrElt -> Maybe FieldLabelString -greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl -greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) -greLabel _ = Nothing - -unQualOK :: GlobalRdrElt -> Bool --- ^ Test if an unqualified version of this thing would be in scope -unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) - | lcl = True - | otherwise = any unQualSpecOK iss - -{- Note [GRE filtering] -~~~~~~~~~~~~~~~~~~~~~~~ -(pickGREs rdr gres) takes a list of GREs which have the same OccName -as 'rdr', say "x". It does two things: - -(a) filters the GREs to a subset that are in scope - * Qualified, as 'M.x' if want_qual is Qual M _ - * Unqualified, as 'x' if want_unqual is Unqual _ - -(b) for that subset, filter the provenance field (gre_lcl and gre_imp) - to ones that brought it into scope qualified or unqualified resp. - -Example: - module A ( f ) where - import qualified Foo( f ) - import Baz( f ) - f = undefined - -Let's suppose that Foo.f and Baz.f are the same entity really, but the local -'f' is different, so there will be two GREs matching "f": - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] - -The use of "f" in the export list is ambiguous because it's in scope -from the local def and the import Baz(f); but *not* the import qualified Foo. -pickGREs returns two GRE - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Bar ] - -Now the "ambiguous occurrence" message can correctly report how the -ambiguity arises. --} - -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] --- ^ Takes a list of GREs which have the right OccName 'x' --- Pick those GREs that are in scope --- * Qualified, as 'M.x' if want_qual is Qual M _ --- * Unqualified, as 'x' if want_unqual is Unqual _ --- --- Return each such GRE, with its ImportSpecs filtered, to reflect --- how it is in scope qualified or unqualified respectively. --- See Note [GRE filtering] -pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres -pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres -pickGREs _ _ = [] -- I don't think this actually happens - -pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt -pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | not lcl, null iss' = Nothing - | otherwise = Just (gre { gre_imp = iss' }) - where - iss' = filter unQualSpecOK iss - -pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt -pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) - | not lcl', null iss' = Nothing - | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) - where - iss' = filter (qualSpecOK mod) iss - lcl' = lcl && name_is_from mod n - - name_is_from :: ModuleName -> Name -> Bool - name_is_from mod name = case nameModule_maybe name of - Just n_mod -> moduleName n_mod == mod - Nothing -> False - -pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] --- ^ Pick GREs that are in scope *both* qualified *and* unqualified --- Return each GRE that is, as a pair --- (qual_gre, unqual_gre) --- These two GREs are the original GRE with imports filtered to express how --- it is in scope qualified an unqualified respectively --- --- Used only for the 'module M' item in export list; --- see GHC.Rename.Names.exports_from_avail -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres - -pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) -pickBothGRE mod gre@(GRE { gre_name = n }) - | isBuiltInSyntax n = Nothing - | Just gre1 <- pickQualGRE mod gre - , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) - | otherwise = Nothing - where - -- isBuiltInSyntax filter out names for built-in syntax They - -- just clutter up the environment (esp tuples), and the - -- parser will generate Exact RdrNames for them, so the - -- cluttered envt is no use. Really, it's only useful for - -- GHC.Base and GHC.Tuple. - --- Building GlobalRdrEnvs - -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 - -mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv -mkGlobalRdrEnv gres - = foldr add emptyGlobalRdrEnv gres - where - add gre env = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) - gre - -insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] -insertGRE new_g [] = [new_g] -insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g - = new_g `plusGRE` old_g : old_gs - | otherwise - = old_g : insertGRE new_g old_gs - -plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt --- Used when the gre_name fields match -plusGRE g1 g2 - = GRE { gre_name = gre_name g1 - , gre_lcl = gre_lcl g1 || gre_lcl g2 - , gre_imp = gre_imp g1 ++ gre_imp g2 - , gre_par = gre_par g1 `plusParent` gre_par g2 } - -transformGREs :: (GlobalRdrElt -> GlobalRdrElt) - -> [OccName] - -> GlobalRdrEnv -> GlobalRdrEnv --- ^ Apply a transformation function to the GREs for these OccNames -transformGREs trans_gre occs rdr_env - = foldr trans rdr_env occs - where - trans occ env - = case lookupOccEnv env occ of - Just gres -> extendOccEnv env occ (map trans_gre gres) - Nothing -> env - -extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre - = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) gre - -shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv -shadowNames = foldl' shadowName - -{- Note [GlobalRdrEnv shadowing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowName. -Suppose - env' = shadowName env M.f - -Then: - * Looking up (Unqual f) in env' should succeed, returning M.f, - even if env contains existing unqualified bindings for f. - They are shadowed - - * Looking up (Qual M.f) in env' should succeed, returning M.f - - * Looking up (Qual X.f) in env', where X /= M, should be the same as - looking up (Qual X.f) in env. - That is, shadowName does /not/ delete earlier qualified bindings - -There are two reasons for shadowing: - -* The GHCi REPL - - - Ids bought into scope on the command line (eg let x = True) have - External Names, like Ghci4.x. We want a new binding for 'x' (say) - to override the existing binding for 'x'. Example: - - ghci> :load M -- Brings `x` and `M.x` into scope - ghci> x - ghci> "Hello" - ghci> M.x - ghci> "hello" - ghci> let x = True -- Shadows `x` - ghci> x -- The locally bound `x` - -- NOT an ambiguous reference - ghci> True - ghci> M.x -- M.x is still in scope! - ghci> "Hello" - So when we add `x = True` we must not delete the `M.x` from the - `GlobalRdrEnv`; rather we just want to make it "qualified only"; - hence the `mk_fake-imp_spec` in `shadowName`. See also Note - [Interactively-bound Ids in GHCi] in GHC.Driver.Types - - - Data types also have External Names, like Ghci4.T; but we still want - 'T' to mean the newly-declared 'T', not an old one. - -* Nested Template Haskell declaration brackets - See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names - - Consider a TH decl quote: - module M where - f x = h [d| f = ...f...M.f... |] - We must shadow the outer unqualified binding of 'f', else we'll get - a complaint when extending the GlobalRdrEnv, saying that there are - two bindings for 'f'. There are several tricky points: - - - This shadowing applies even if the binding for 'f' is in a - where-clause, and hence is in the *local* RdrEnv not the *global* - RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. - - - The External Name M.f from the enclosing module must certainly - still be available. So we don't nuke it entirely; we just make - it seem like qualified import. - - - We only shadow *External* names (which come from the main module), - or from earlier GHCi commands. Do not shadow *Internal* names - because in the bracket - [d| class C a where f :: a - f = 4 |] - rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the - class decl, and *separately* extend the envt with the value binding. - At that stage, the class op 'f' will have an Internal name. --} - -shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv --- Remove certain old GREs that share the same OccName as this new Name. --- See Note [GlobalRdrEnv shadowing] for details -shadowName env name - = alterOccEnv (fmap alter_fn) env (nameOccName name) - where - alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] - alter_fn gres = mapMaybe (shadow_with name) gres - - shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt - shadow_with new_name - old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) - = case nameModule_maybe old_name of - Nothing -> Just old_gre -- Old name is Internal; do not shadow - Just old_mod - | Just new_mod <- nameModule_maybe new_name - , new_mod == old_mod -- Old name same as new name; shadow completely - -> Nothing - - | null iss' -- Nothing remains - -> Nothing - - | otherwise - -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) - - where - iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss - lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] - | otherwise = [] - - mk_fake_imp_spec old_name old_mod -- Urgh! - = ImpSpec id_spec ImpAll - where - old_mod_name = moduleName old_mod - id_spec = ImpDeclSpec { is_mod = old_mod_name - , is_as = old_mod_name - , is_qual = True - , is_dloc = nameSrcSpan old_name } - - shadow_is :: Name -> ImportSpec -> Maybe ImportSpec - shadow_is new_name is@(ImpSpec { is_decl = id_spec }) - | Just new_mod <- nameModule_maybe new_name - , is_as id_spec == moduleName new_mod - = Nothing -- Shadow both qualified and unqualified - | otherwise -- Shadow unqualified only - = Just (is { is_decl = id_spec { is_qual = True } }) - - -{- -************************************************************************ -* * - ImportSpec -* * -************************************************************************ --} - --- | Import Specification --- --- The 'ImportSpec' of something says how it came to be imported --- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } - deriving( Eq, Data ) - --- | Import Declaration Specification --- --- Describes a particular import declaration and is --- shared among all the 'Provenance's for that decl -data ImpDeclSpec - = ImpDeclSpec { - is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ - -- Note the @Muggle@ may well not be - -- the defining module for this thing! - - -- TODO: either should be Module, or there - -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration - } deriving (Eq, Data) - --- | Import Item Specification --- --- Describes import info a particular Name -data ImpItemSpec - = ImpAll -- ^ The import had no import list, - -- or had a hiding list - - | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item - } -- ^ The import had an import list. - -- The 'is_explicit' field is @True@ iff the thing was named - -- /explicitly/ in the import specs rather - -- than being imported as part of a "..." group. Consider: - -- - -- > import C( T(..) ) - -- - -- Here the constructors of @T@ are not named explicitly; - -- only @T@ is named explicitly. - deriving (Eq, Data) - -bestImport :: [ImportSpec] -> ImportSpec --- See Note [Choosing the best import declaration] -bestImport iss - = case sortBy best iss of - (is:_) -> is - [] -> pprPanic "bestImport" (ppr iss) - where - best :: ImportSpec -> ImportSpec -> Ordering - -- Less means better - -- Unqualified always wins over qualified; then - -- import-all wins over import-some; then - -- earlier declaration wins over later - best (ImpSpec { is_item = item1, is_decl = d1 }) - (ImpSpec { is_item = item2, is_decl = d2 }) - = (is_qual d1 `compare` is_qual d2) `thenCmp` - (best_item item1 item2) `thenCmp` - SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) - - best_item :: ImpItemSpec -> ImpItemSpec -> Ordering - best_item ImpAll ImpAll = EQ - best_item ImpAll (ImpSome {}) = LT - best_item (ImpSome {}) ImpAll = GT - best_item (ImpSome { is_explicit = e1 }) - (ImpSome { is_explicit = e2 }) = e1 `compare` e2 - -- False < True, so if e1 is explicit and e2 is not, we get GT - -{- Note [Choosing the best import declaration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reporting unused import declarations we use the following rules. - (see [wiki:commentary/compiler/unused-imports]) - -Say that an import-item is either - * an entire import-all decl (eg import Foo), or - * a particular item in an import list (eg import Foo( ..., x, ...)). -The general idea is that for each /occurrence/ of an imported name, we will -attribute that use to one import-item. Once we have processed all the -occurrences, any import items with no uses attributed to them are unused, -and are warned about. More precisely: - -1. For every RdrName in the program text, find its GlobalRdrElt. - -2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one - the "chosen import-item", and mark it "used". This is done - by 'bestImport' - -3. After processing all the RdrNames, bleat about any - import-items that are unused. - This is done in GHC.Rename.Names.warnUnusedImportDecls. - -The function 'bestImport' returns the dominant import among the -ImportSpecs it is given, implementing Step 2. We say import-item A -dominates import-item B if we choose A over B. In general, we try to -choose the import that is most likely to render other imports -unnecessary. Here is the dominance relationship we choose: - - a) import Foo dominates import qualified Foo. - - b) import Foo dominates import Foo(x). - - c) Otherwise choose the textually first one. - -Rationale for (a). Consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + x - -The unqualified 'x' can only come from import #2. The qualified 'M.x' -could come from either, but bestImport picks import #2, because it is -more likely to be useful in other imports, as indeed it is in this -case (see #5211 for a concrete example). - -But the rules are not perfect; consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + M.y - -The M.x will use import #2, but M.y can only use import #1. --} - - -unQualSpecOK :: ImportSpec -> Bool --- ^ Is in scope unqualified? -unQualSpecOK is = not (is_qual (is_decl is)) - -qualSpecOK :: ModuleName -> ImportSpec -> Bool --- ^ Is in scope qualified with the given module? -qualSpecOK mod is = mod == is_as (is_decl is) - -importSpecLoc :: ImportSpec -> SrcSpan -importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl -importSpecLoc (ImpSpec _ item) = is_iloc item - -importSpecModule :: ImportSpec -> ModuleName -importSpecModule is = is_mod (is_decl is) - -isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False -isExplicitItem (ImpSome {is_explicit = exp}) = exp - -pprNameProvenance :: GlobalRdrElt -> SDoc --- ^ Print out one place where the name was define/imported --- (With -dppr-debug, print them all) -pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - = ifPprDebug (vcat pp_provs) - (head pp_provs) - where - pp_provs = pp_lcl ++ map pp_is iss - pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] - else [] - pp_is is = sep [ppr is, ppr_defn_site is name] - --- If we know the exact definition point (which we may do with GHCi) --- then show that too. But not if it's just "imported from X". -ppr_defn_site :: ImportSpec -> Name -> SDoc -ppr_defn_site imp_spec name - | same_module && not (isGoodSrcSpan loc) - = empty -- Nothing interesting to say - | otherwise - = parens $ hang (text "and originally defined" <+> pp_mod) - 2 (pprLoc loc) - where - loc = nameSrcSpan name - defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - same_module = importSpecModule imp_spec == moduleName defining_mod - pp_mod | same_module = empty - | otherwise = text "in" <+> quotes (ppr defining_mod) - - -instance Outputable ImportSpec where - ppr imp_spec - = text "imported" <+> qual - <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) - <+> pprLoc (importSpecLoc imp_spec) - where - qual | is_qual (is_decl imp_spec) = text "qualified" - | otherwise = empty - -pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s _) = text "at" <+> ppr s -pprLoc (UnhelpfulSpan {}) = empty - --- | Display info about the treatment of '*' under NoStarIsType. --- --- With StarIsType, three properties of '*' hold: --- --- (a) it is not an infix operator --- (b) it is always in scope --- (c) it is a synonym for Data.Kind.Type --- --- However, the user might not know that he's working on a module with --- NoStarIsType and write code that still assumes (a), (b), and (c), which --- actually do not hold in that module. --- --- Violation of (a) shows up in the parser. For instance, in the following --- examples, we have '*' not applied to enough arguments: --- --- data A :: * --- data F :: * -> * --- --- Violation of (b) or (c) show up in the renamer and the typechecker --- respectively. For instance: --- --- type K = Either * Bool --- --- This will parse differently depending on whether StarIsType is enabled, --- but it will parse nonetheless. With NoStarIsType it is parsed as a type --- operator, thus we have ((*) Either Bool). Now there are two cases to --- consider: --- --- 1. There is no definition of (*) in scope. In this case the renamer will --- fail to look it up. This is a violation of assumption (b). --- --- 2. There is a definition of the (*) type operator in scope (for example --- coming from GHC.TypeNats). In this case the user will get a kind --- mismatch error. This is a violation of assumption (c). --- --- The user might unknowingly be working on a module with NoStarIsType --- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a --- hint whenever an assumption about '*' is violated. Unfortunately, it is --- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). --- --- 'starInfo' generates an appropriate hint to the user depending on the --- extensions enabled in the module and the name that triggered the error. --- That is, if we have NoStarIsType and the error is related to '*' or its --- Unicode variant, the resulting SDoc will contain a helpful suggestion. --- Otherwise it is empty. --- -starInfo :: Bool -> RdrName -> SDoc -starInfo star_is_type rdr_name = - -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to - -- take star_is_type as input? Why not refactor? - -- - -- The reason is that `sdocOption sdocStarIsType` would indicate that - -- StarIsType is enabled in the module that tries to load the problematic - -- definition, not in the module that is being loaded. - -- - -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint - -- must be displayed even if we load this definition from a module (or GHCi) - -- with StarIsType enabled! - -- - if isUnqualStar && not star_is_type - then text "With NoStarIsType, " <> - quotes (ppr rdr_name) <> - text " is treated as a regular type operator. " - $$ - text "Did you mean to use " <> quotes (text "Type") <> - text " from Data.Kind instead?" - else empty - where - -- Does rdr_name look like the user might have meant the '*' kind by it? - -- We focus on unqualified stars specifically, because qualified stars are - -- treated as type operators even under StarIsType. - isUnqualStar - | Unqual occName <- rdr_name - = let fs = occNameFS occName - in fs == fsLit "*" || fs == fsLit "★" - | otherwise = False diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs deleted file mode 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ /dev/null @@ -1,741 +0,0 @@ --- (c) The University of Glasgow, 1992-2006 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} - - --- | This module contains types that relate to the positions of things --- in source files, and allow tagging of those things with locations -module SrcLoc ( - -- * SrcLoc - RealSrcLoc, -- Abstract - SrcLoc(..), - - -- ** Constructing SrcLoc - mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, - - noSrcLoc, -- "I'm sorry, I haven't a clue" - generatedSrcLoc, -- Code generated within the compiler - interactiveSrcLoc, -- Code from an interactive session - - advanceSrcLoc, - advanceBufPos, - - -- ** Unsafely deconstructing SrcLoc - -- These are dubious exports, because they crash on some inputs - srcLocFile, -- return the file name part - srcLocLine, -- return the line part - srcLocCol, -- return the column part - - -- * SrcSpan - RealSrcSpan, -- Abstract - SrcSpan(..), - - -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, - noSrcSpan, - wiredInSrcSpan, -- Something wired into the compiler - interactiveSrcSpan, - srcLocSpan, realSrcLocSpan, - combineSrcSpans, - srcSpanFirstCharacter, - - -- ** Deconstructing SrcSpan - srcSpanStart, srcSpanEnd, - realSrcSpanStart, realSrcSpanEnd, - srcSpanFileName_maybe, - pprUserRealSpan, - - -- ** Unsafely deconstructing SrcSpan - -- These are dubious exports, because they crash on some inputs - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Predicates on SrcSpan - isGoodSrcSpan, isOneLineSpan, - containsSpan, - - -- * StringBuffer locations - BufPos(..), - BufSpan(..), - - -- * Located - Located, - RealLocated, - GenLocated(..), - - -- ** Constructing Located - noLoc, - mkGeneralLocated, - - -- ** Deconstructing Located - getLoc, unLoc, - unRealSrcSpan, getRealSrcSpan, - - -- ** Modifying Located - mapLoc, - - -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost_smallest, - spans, isSubspanOf, isRealSubspanOf, sortLocated, - sortRealLocated, - lookupSrcLoc, lookupSrcSpan, - - liftL, - - -- * Parser locations - PsLoc(..), - PsSpan(..), - PsLocated, - advancePsLoc, - mkPsSpan, - psSpanStart, - psSpanEnd, - mkSrcSpanPs, - - ) where - -import GhcPrelude - -import Util -import Json -import Outputable -import FastString - -import Control.DeepSeq -import Control.Applicative (liftA2) -import Data.Bits -import Data.Data -import Data.List (sortBy, intercalate) -import Data.Function (on) -import qualified Data.Map as Map - -{- -************************************************************************ -* * -\subsection[SrcLoc-SrcLocations]{Source-location information} -* * -************************************************************************ - -We keep information about the {\em definition} point for each entity; -this is the obvious stuff: --} - --- | Real Source Location --- --- Represents a single point within a file -data RealSrcLoc - = SrcLoc FastString -- A precise location (file name) - {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 1 - deriving (Eq, Ord) - --- | 0-based index identifying the raw location in the StringBuffer. --- --- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-} --- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in --- Lexer.x update 'PsLoc' preserving 'BufPos'. --- --- The parser guarantees that 'BufPos' are monotonic. See #17632. -newtype BufPos = BufPos { bufPos :: Int } - deriving (Eq, Ord, Show) - --- | Source Location -data SrcLoc - = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos] - | UnhelpfulLoc FastString -- Just a general indication - deriving (Eq, Show) - -{- -************************************************************************ -* * -\subsection[SrcLoc-access-fns]{Access functions} -* * -************************************************************************ --} - -mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing - -mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc -mkRealSrcLoc x line col = SrcLoc x line col - --- | Built-in "bad" 'SrcLoc' values for particular locations -noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc -noSrcLoc = UnhelpfulLoc (fsLit "") -generatedSrcLoc = UnhelpfulLoc (fsLit "") -interactiveSrcLoc = UnhelpfulLoc (fsLit "") - --- | Creates a "bad" 'SrcLoc' that has no detailed information about its location -mkGeneralSrcLoc :: FastString -> SrcLoc -mkGeneralSrcLoc = UnhelpfulLoc - --- | Gives the filename of the 'RealSrcLoc' -srcLocFile :: RealSrcLoc -> FastString -srcLocFile (SrcLoc fname _ _) = fname - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocLine :: RealSrcLoc -> Int -srcLocLine (SrcLoc _ l _) = l - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocCol :: RealSrcLoc -> Int -srcLocCol (SrcLoc _ _ c) = c - --- | Move the 'SrcLoc' down by one line if the character is a newline, --- to the next 8-char tabstop if it is a tab, and across by one --- character in any other case -advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc -advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 -advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) -advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) - -advance_tabstop :: Int -> Int -advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 - -advanceBufPos :: BufPos -> BufPos -advanceBufPos (BufPos i) = BufPos (i+1) - -{- -************************************************************************ -* * -\subsection[SrcLoc-instances]{Instance declarations for various names} -* * -************************************************************************ --} - -sortLocated :: [Located a] -> [Located a] -sortLocated = sortBy (leftmost_smallest `on` getLoc) - -sortRealLocated :: [RealLocated a] -> [RealLocated a] -sortRealLocated = sortBy (compare `on` getLoc) - -lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a -lookupSrcLoc (RealSrcLoc l _) = Map.lookup l -lookupSrcLoc (UnhelpfulLoc _) = const Nothing - -lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a -lookupSrcSpan (RealSrcSpan l _) = Map.lookup l -lookupSrcSpan (UnhelpfulSpan _) = const Nothing - -instance Outputable RealSrcLoc where - ppr (SrcLoc src_path src_line src_col) - = hcat [ pprFastFilePath src_path <> colon - , int src_line <> colon - , int src_col ] - --- I don't know why there is this style-based difference --- if userStyle sty || debugStyle sty then --- hcat [ pprFastFilePath src_path, char ':', --- int src_line, --- char ':', int src_col --- ] --- else --- hcat [text "{-# LINE ", int src_line, space, --- char '\"', pprFastFilePath src_path, text " #-}"] - -instance Outputable SrcLoc where - ppr (RealSrcLoc l _) = ppr l - ppr (UnhelpfulLoc s) = ftext s - -instance Data RealSrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "RealSrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "RealSrcSpan" - -instance Data SrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "SrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "SrcSpan" - -{- -************************************************************************ -* * -\subsection[SrcSpan]{Source Spans} -* * -************************************************************************ --} - -{- | -A 'RealSrcSpan' delimits a portion of a text file. It could be represented -by a pair of (line,column) coordinates, but in fact we optimise -slightly by using more compact representations for single-line and -zero-length spans, both of which are quite common. - -The end position is defined to be the column /after/ the end of the -span. That is, a span of (1,1)-(1,2) is one character long, and a -span of (1,1)-(1,1) is zero characters long. --} - --- | Real Source Span -data RealSrcSpan - = RealSrcSpan' - { srcSpanFile :: !FastString, - srcSpanSLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } - deriving Eq - --- | StringBuffer Source Span -data BufSpan = - BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } - deriving (Eq, Ord, Show) - --- | Source Span --- --- A 'SrcSpan' identifies either a specific portion of a text file --- or a human-readable description of a location. -data SrcSpan = - RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] - | UnhelpfulSpan !FastString -- Just a general indication - -- also used to indicate an empty span - - deriving (Eq, Show) -- Show is used by Lexer.x, because we - -- derive Show for Token - -{- Note [Why Maybe BufPos] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). -Why the Maybe? - -Surely, the lexer can always fill in the buffer position, and it guarantees to do so. -However, sometimes the SrcLoc/SrcSpan is constructed in a different context -where the buffer location is not available, and then we use Nothing instead of -a fake value like BufPos (-1). - -Perhaps the compiler could be re-engineered to pass around BufPos more -carefully and never discard it, and this 'Maybe' could be removed. If you're -interested in doing so, you may find this ripgrep query useful: - - rg "RealSrc(Loc|Span).*?Nothing" - -For example, it is not uncommon to whip up source locations for e.g. error -messages, constructing a SrcSpan without a BufSpan. --} - -instance ToJson SrcSpan where - json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] - json (RealSrcSpan rss _) = json rss - -instance ToJson RealSrcSpan where - json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) - , ("startLine", JSInt srcSpanSLine) - , ("startCol", JSInt srcSpanSCol) - , ("endLine", JSInt srcSpanELine) - , ("endCol", JSInt srcSpanECol) - ] - -instance NFData SrcSpan where - rnf x = x `seq` () - --- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "") -wiredInSrcSpan = UnhelpfulSpan (fsLit "") -interactiveSrcSpan = UnhelpfulSpan (fsLit "") - --- | Create a "bad" 'SrcSpan' that has not location information -mkGeneralSrcSpan :: FastString -> SrcSpan -mkGeneralSrcSpan = UnhelpfulSpan - --- | Create a 'SrcSpan' corresponding to a single point -srcLocSpan :: SrcLoc -> SrcSpan -srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) - -realSrcLocSpan :: RealSrcLoc -> RealSrcSpan -realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col - --- | Create a 'SrcSpan' between two points in a file -mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan -mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 - where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 - --- | 'True' if the span is known to straddle only one line. -isOneLineRealSpan :: RealSrcSpan -> Bool -isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) - = line1 == line2 - --- | 'True' if the span is a single point -isPointRealSpan :: RealSrcSpan -> Bool -isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) - = line1 == line2 && col1 == col2 - --- | Create a 'SrcSpan' between two points in a file -mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) - = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Returns UnhelpfulSpan if the files differ. -combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful -combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) - | srcSpanFile span1 == srcSpanFile span2 - = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) - | otherwise = UnhelpfulSpan (fsLit "") - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Assumes the "file" part is the same in both inputs -combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan -combineRealSrcSpans span1 span2 - = RealSrcSpan' file line_start col_start line_end col_end - where - (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) - (srcSpanStartLine span2, srcSpanStartCol span2) - (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) - (srcSpanEndLine span2, srcSpanEndCol span2) - file = srcSpanFile span1 - -combineBufSpans :: BufSpan -> BufSpan -> BufSpan -combineBufSpans span1 span2 = BufSpan start end - where - start = min (bufSpanStart span1) (bufSpanStart span2) - end = max (bufSpanEnd span1) (bufSpanEnd span2) - - --- | Convert a SrcSpan into one that represents only its first character -srcSpanFirstCharacter :: SrcSpan -> SrcSpan -srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l -srcSpanFirstCharacter (RealSrcSpan span mbspan) = - RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) - where - loc1@(SrcLoc f l c) = realSrcSpanStart span - loc2 = SrcLoc f l (c+1) - mkBufSpan bspan = - let bpos1@(BufPos i) = bufSpanStart bspan - bpos2 = BufPos (i+1) - in BufSpan bpos1 bpos2 - -{- -************************************************************************ -* * -\subsection[SrcSpan-predicates]{Predicates} -* * -************************************************************************ --} - --- | Test if a 'SrcSpan' is "good", i.e. has precise location information -isGoodSrcSpan :: SrcSpan -> Bool -isGoodSrcSpan (RealSrcSpan _ _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False - -isOneLineSpan :: SrcSpan -> Bool --- ^ True if the span is known to straddle only one line. --- For "bad" 'SrcSpan', it returns False -isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False - --- | Tests whether the first span "contains" the other span, meaning --- that it covers at least as much source code. True where spans are equal. -containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool -containsSpan s1 s2 - = (srcSpanStartLine s1, srcSpanStartCol s1) - <= (srcSpanStartLine s2, srcSpanStartCol s2) - && (srcSpanEndLine s1, srcSpanEndCol s1) - >= (srcSpanEndLine s2, srcSpanEndCol s2) - && (srcSpanFile s1 == srcSpanFile s2) - -- We check file equality last because it is (presumably?) least - -- likely to fail. -{- -%************************************************************************ -%* * -\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} -* * -************************************************************************ --} - -srcSpanStartLine :: RealSrcSpan -> Int -srcSpanEndLine :: RealSrcSpan -> Int -srcSpanStartCol :: RealSrcSpan -> Int -srcSpanEndCol :: RealSrcSpan -> Int - -srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l -srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l -srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l -srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c - -{- -************************************************************************ -* * -\subsection[SrcSpan-access-fns]{Access functions} -* * -************************************************************************ --} - --- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanStart :: SrcSpan -> SrcLoc -srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) - --- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanEnd :: SrcSpan -> SrcLoc -srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) - -realSrcSpanStart :: RealSrcSpan -> RealSrcLoc -realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) - (srcSpanStartLine s) - (srcSpanStartCol s) - -realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc -realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) - (srcSpanEndLine s) - (srcSpanEndCol s) - --- | Obtains the filename for a 'SrcSpan' if it is "good" -srcSpanFileName_maybe :: SrcSpan -> Maybe FastString -srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing - -{- -************************************************************************ -* * -\subsection[SrcSpan-instances]{Instances} -* * -************************************************************************ --} - --- We want to order RealSrcSpans first by the start point, then by the --- end point. -instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) - -instance Show RealSrcLoc where - show (SrcLoc filename row col) - = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col - --- Show is used by Lexer.x, because we derive Show for Token -instance Show RealSrcSpan where - show span@(RealSrcSpan' file sl sc el ec) - | isPointRealSpan span - = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) - - | isOneLineRealSpan span - = "SrcSpanOneLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,ec]) - - | otherwise - = "SrcSpanMultiLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,el,ec]) - - -instance Outputable RealSrcSpan where - ppr span = pprUserRealSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- text (showUserRealSpan True span) --- else --- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, --- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] - -instance Outputable SrcSpan where - ppr span = pprUserSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- pprUserSpan True span --- else --- case span of --- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" --- RealSrcSpan s -> ppr s - -pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan _ (UnhelpfulSpan s) = ftext s -pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s - -pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc -pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) - | isPointRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int col ] - -pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) - | isOneLineRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int scol - , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] - -- For single-character or point spans, we just - -- output the starting column number - -pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , parens (int sline <> comma <> int scol) - , char '-' - , parens (int eline <> comma <> int ecol') ] - where - ecol' = if ecol == 0 then ecol else ecol - 1 - -{- -************************************************************************ -* * -\subsection[Located]{Attaching SrcSpans to things} -* * -************************************************************************ --} - --- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data GenLocated l e = L l e - deriving (Eq, Ord, Data, Functor, Foldable, Traversable) - -type Located = GenLocated SrcSpan -type RealLocated = GenLocated RealSrcSpan - -mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b -mapLoc = fmap - -unLoc :: GenLocated l e -> e -unLoc (L _ e) = e - -getLoc :: GenLocated l e -> l -getLoc (L l _) = l - -noLoc :: e -> Located e -noLoc e = L noSrcSpan e - -mkGeneralLocated :: String -> e -> Located e -mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e - -combineLocs :: Located a -> Located b -> SrcSpan -combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) - --- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: Located a -> Located b -> c -> Located c -addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c - --- not clear whether to add a general Eq instance, but this is useful sometimes: - --- | Tests whether the two located things are equal -eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool -eqLocated a b = unLoc a == unLoc b - --- not clear whether to add a general Ord instance, but this is useful sometimes: - --- | Tests the ordering of the two located things -cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering -cmpLocated a b = unLoc a `compare` unLoc b - -instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where - ppr (L l e) = -- TODO: We can't do this since Located was refactored into - -- GenLocated: - -- Print spans without the file name etc - -- ifPprDebug (braces (pprUserSpan False l)) - whenPprDebug (braces (ppr l)) - $$ ppr e - -{- -************************************************************************ -* * -\subsection{Ordering SrcSpans for InteractiveUI} -* * -************************************************************************ --} - --- | Strategies for ordering 'SrcSpan's -leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering -rightmost_smallest = compareSrcSpanBy (flip compare) -leftmost_smallest = compareSrcSpanBy compare -leftmost_largest = compareSrcSpanBy $ \a b -> - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) - -compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering -compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b -compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT -compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT -compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ - --- | Determines whether a span encloses a given line and column index -spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" -spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span - where loc = mkRealSrcLoc (srcSpanFile span) l c - --- | Determines whether a span is enclosed by another one -isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other - -> SrcSpan -- ^ The span it may be enclosed by - -> Bool -isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent -isSubspanOf _ _ = False - --- | Determines whether a span is enclosed by another one -isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other - -> RealSrcSpan -- ^ The span it may be enclosed by - -> Bool -isRealSubspanOf src parent - | srcSpanFile parent /= srcSpanFile src = False - | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && - realSrcSpanEnd parent >= realSrcSpanEnd src - -liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - -getRealSrcSpan :: RealLocated a -> RealSrcSpan -getRealSrcSpan (L l _) = l - -unRealSrcSpan :: RealLocated a -> a -unRealSrcSpan (L _ e) = e - - --- | A location as produced by the parser. Consists of two components: --- --- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) --- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) -data PsLoc - = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } - deriving (Eq, Ord, Show) - -data PsSpan - = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } - deriving (Eq, Ord, Show) - -type PsLocated = GenLocated PsSpan - -advancePsLoc :: PsLoc -> Char -> PsLoc -advancePsLoc (PsLoc real_loc buf_loc) c = - PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) - -mkPsSpan :: PsLoc -> PsLoc -> PsSpan -mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) - -psSpanStart :: PsSpan -> PsLoc -psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) - -psSpanEnd :: PsSpan -> PsLoc -psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) - -mkSrcSpanPs :: PsSpan -> SrcSpan -mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs deleted file mode 100644 --- a/compiler/basicTypes/UniqSupply.hs +++ /dev/null @@ -1,224 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} - -#if !defined(GHC_LOADED_INTO_GHCI) -{-# LANGUAGE UnboxedTuples #-} -#endif - -module UniqSupply ( - -- * Main data type - UniqSupply, -- Abstractly - - -- ** Operations on supplies - uniqFromSupply, uniqsFromSupply, -- basic ops - takeUniqFromSupply, uniqFromMask, - - mkSplitUniqSupply, - splitUniqSupply, listSplitUniqSupply, - - -- * Unique supply monad and its abstraction - UniqSM, MonadUnique(..), - - -- ** Operations on the monad - initUs, initUs_, - - -- * Set supply strategy - initUniqSupply - ) where - -import GhcPrelude - -import Unique -import PlainPanic (panic) - -import GHC.IO - -import MonadUtils -import Control.Monad -import Data.Bits -import Data.Char -import Control.Monad.Fail as Fail - -#include "Unique.h" - -{- -************************************************************************ -* * -\subsection{Splittable Unique supply: @UniqSupply@} -* * -************************************************************************ --} - --- | Unique Supply --- --- A value of type 'UniqSupply' is unique, and it can --- supply /one/ distinct 'Unique'. Also, from the supply, one can --- also manufacture an arbitrary number of further 'UniqueSupply' values, --- which will be distinct from the first and from all others. -data UniqSupply - = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this - UniqSupply UniqSupply - -- when split => these two supplies - -mkSplitUniqSupply :: Char -> IO UniqSupply --- ^ Create a unique supply out of thin air. The character given must --- be distinct from those of all calls to this function in the compiler --- for the values generated to be truly unique. - -splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) --- ^ Build two 'UniqSupply' from a single one, each of which --- can supply its own 'Unique'. -listSplitUniqSupply :: UniqSupply -> [UniqSupply] --- ^ Create an infinite list of 'UniqSupply' from a single one -uniqFromSupply :: UniqSupply -> Unique --- ^ Obtain the 'Unique' from this particular 'UniqSupply' -uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite --- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply -takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) --- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply - -uniqFromMask :: Char -> IO Unique -uniqFromMask mask - = do { uqNum <- genSym - ; return $! mkUnique mask uqNum } - -mkSplitUniqSupply c - = case ord c `shiftL` uNIQUE_BITS of - !mask -> let - -- here comes THE MAGIC: - - -- This is one of the most hammered bits in the whole compiler - mk_supply - -- NB: Use unsafeInterleaveIO for thread-safety. - = unsafeInterleaveIO ( - genSym >>= \ u -> - mk_supply >>= \ s1 -> - mk_supply >>= \ s2 -> - return (MkSplitUniqSupply (mask .|. u) s1 s2) - ) - in - mk_supply - -foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int -foreign import ccall unsafe "ghc_lib_parser_initGenSym" initUniqSupply :: Int -> Int -> IO () - -splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) -listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 - -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 -takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) - -{- -************************************************************************ -* * -\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} -* * -************************************************************************ --} - --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - -type UniqResult result = (# result, UniqSupply #) - -pattern UniqResult :: a -> b -> (# a, b #) -pattern UniqResult x y = (# x, y #) -{-# COMPLETE UniqResult #-} - -#else - -data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply - deriving (Functor) - -#endif - --- | A monad which just gives the ability to obtain 'Unique's -newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } - deriving (Functor) - -instance Monad UniqSM where - (>>=) = thenUs - (>>) = (*>) - -instance Applicative UniqSM where - pure = returnUs - (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of - UniqResult ff us1 -> case x us1 of - UniqResult xx us2 -> UniqResult (ff xx) us2 - (*>) = thenUs_ - --- TODO: try to get rid of this instance -instance Fail.MonadFail UniqSM where - fail = panic - --- | Run the 'UniqSM' action, returning the final 'UniqSupply' -initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) -initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } - --- | Run the 'UniqSM' action, discarding the final 'UniqSupply' -initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } - -{-# INLINE thenUs #-} -{-# INLINE returnUs #-} -{-# INLINE splitUniqSupply #-} - --- @thenUs@ is where we split the @UniqSupply@. - -liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) -liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) - -instance MonadFix UniqSM where - mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) - -thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs (USM expr) cont - = USM (\us0 -> case (expr us0) of - UniqResult result us1 -> unUSM (cont result) us1) - -thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ (USM expr) (USM cont) - = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) - -returnUs :: a -> UniqSM a -returnUs result = USM (\us -> UniqResult result us) - -getUs :: UniqSM UniqSupply -getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) - --- | A monad for generating unique identifiers -class Monad m => MonadUnique m where - -- | Get a new UniqueSupply - getUniqueSupplyM :: m UniqSupply - -- | Get a new unique identifier - getUniqueM :: m Unique - -- | Get an infinite list of new unique identifiers - getUniquesM :: m [Unique] - - -- This default definition of getUniqueM, while correct, is not as - -- efficient as it could be since it needlessly generates and throws away - -- an extra Unique. For your instances consider providing an explicit - -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. - getUniqueM = liftM uniqFromSupply getUniqueSupplyM - getUniquesM = liftM uniqsFromSupply getUniqueSupplyM - -instance MonadUnique UniqSM where - getUniqueSupplyM = getUs - getUniqueM = getUniqueUs - getUniquesM = getUniquesUs - -getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of - (u,us1) -> UniqResult u us1) - -getUniquesUs :: UniqSM [Unique] -getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of - (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs deleted file mode 100644 --- a/compiler/basicTypes/Unique.hs +++ /dev/null @@ -1,448 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@Uniques@ are used to distinguish entities in the compiler (@Ids@, -@Classes@, etc.) from each other. Thus, @Uniques@ are the basic -comparison key in the compiler. - -If there is any single operation that needs to be fast, it is @Unique@ - -comparison. Unsurprisingly, there is quite a bit of huff-and-puff -directed to that end. - -Some of the other hair in this code is to be able to use a -``splittable @UniqueSupply@'' if requested/possible (not standard -Haskell). --} - -{-# LANGUAGE CPP, BangPatterns, MagicHash #-} - -module Unique ( - -- * Main data types - Unique, Uniquable(..), - uNIQUE_BITS, - - -- ** Constructors, destructors and operations on 'Unique's - hasKey, - - pprUniqueAlways, - - mkUniqueGrimily, -- Used in UniqSupply only! - getKey, -- Used in Var, UniqFM, Name only! - mkUnique, unpkUnique, -- Used in GHC.Iface.Binary only - eqUnique, ltUnique, - incrUnique, - - newTagUnique, -- Used in CgCase - initTyVarUnique, - initExitJoinUnique, - nonDetCmpUnique, - isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay - - -- ** Making built-in uniques - - -- now all the built-in Uniques (and functions to make them) - -- [the Oh-So-Wonderful Haskell module system wins again...] - mkAlphaTyVarUnique, - mkPrimOpIdUnique, mkPrimOpWrapperUnique, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkCoVarUnique, - - mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, - mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, - mkCostCentreUnique, - - mkBuiltinUnique, - mkPseudoUniqueD, - mkPseudoUniqueE, - mkPseudoUniqueH, - - -- ** Deriving uniques - -- *** From TyCon name uniques - tyConRepNameUnique, - -- *** From DataCon name uniques - dataConWorkerUnique, dataConTyRepNameUnique, - - -- ** Local uniques - -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which - -- has rather peculiar needs. See Note [Local uniques]. - mkLocalUnique, minLocalUnique, maxLocalUnique - ) where - -#include "HsVersions.h" -#include "Unique.h" - -import GhcPrelude - -import BasicTypes -import FastString -import Outputable -import Util - --- just for implementing a fast [0,61) -> Char function -import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) - -import Data.Char ( chr, ord ) -import Data.Bits - -{- -************************************************************************ -* * -\subsection[Unique-type]{@Unique@ type and operations} -* * -************************************************************************ - -The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. -Fast comparison is everything on @Uniques@: --} - --- | Unique identifier. --- --- The type of unique identifiers that are used in many places in GHC --- for fast ordering and equality tests. You should generate these with --- the functions from the 'UniqSupply' module --- --- These are sometimes also referred to as \"keys\" in comments in GHC. -newtype Unique = MkUnique Int - -{-# INLINE uNIQUE_BITS #-} -uNIQUE_BITS :: Int -uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS - -{- -Now come the functions which construct uniques from their pieces, and vice versa. -The stuff about unique *supplies* is handled further down this module. --} - -unpkUnique :: Unique -> (Char, Int) -- The reverse - -mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply -getKey :: Unique -> Int -- for Var - -incrUnique :: Unique -> Unique -stepUnique :: Unique -> Int -> Unique -newTagUnique :: Unique -> Char -> Unique - -mkUniqueGrimily = MkUnique - -{-# INLINE getKey #-} -getKey (MkUnique x) = x - -incrUnique (MkUnique i) = MkUnique (i + 1) -stepUnique (MkUnique i) n = MkUnique (i + n) - -mkLocalUnique :: Int -> Unique -mkLocalUnique i = mkUnique 'X' i - -minLocalUnique :: Unique -minLocalUnique = mkLocalUnique 0 - -maxLocalUnique :: Unique -maxLocalUnique = mkLocalUnique uniqueMask - --- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u - --- | How many bits are devoted to the unique index (as opposed to the class --- character). -uniqueMask :: Int -uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 - --- pop the Char in the top 8 bits of the Unique(Supply) - --- No 64-bit bugs here, as long as we have at least 32 bits. --JSM - --- and as long as the Char fits in 8 bits, which we assume anyway! - -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces --- NOT EXPORTED, so that we can see all the Chars that --- are used in this one module -mkUnique c i - = MkUnique (tag .|. bits) - where - tag = ord c `shiftL` uNIQUE_BITS - bits = i .&. uniqueMask - -unpkUnique (MkUnique u) - = let - -- as long as the Char may have its eighth bit set, we - -- really do need the logical right-shift here! - tag = chr (u `shiftR` uNIQUE_BITS) - i = u .&. uniqueMask - in - (tag, i) - --- | The interface file symbol-table encoding assumes that known-key uniques fit --- in 30-bits; verify this. --- --- See Note [Symbol table representation of names] in GHC.Iface.Binary for details. -isValidKnownKeyUnique :: Unique -> Bool -isValidKnownKeyUnique u = - case unpkUnique u of - (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) - -{- -************************************************************************ -* * -\subsection[Uniquable-class]{The @Uniquable@ class} -* * -************************************************************************ --} - --- | Class of things that we can obtain a 'Unique' from -class Uniquable a where - getUnique :: a -> Unique - -hasKey :: Uniquable a => a -> Unique -> Bool -x `hasKey` k = getUnique x == k - -instance Uniquable FastString where - getUnique fs = mkUniqueGrimily (uniqueOfFS fs) - -instance Uniquable Int where - getUnique i = mkUniqueGrimily i - -{- -************************************************************************ -* * -\subsection[Unique-instances]{Instance declarations for @Unique@} -* * -************************************************************************ - -And the whole point (besides uniqueness) is fast equality. We don't -use `deriving' because we want {\em precise} control of ordering -(equality on @Uniques@ is v common). --} - --- Note [Unique Determinism] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of allocated @Uniques@ is not stable across rebuilds. --- The main reason for that is that typechecking interface files pulls --- @Uniques@ from @UniqSupply@ and the interface file for the module being --- currently compiled can, but doesn't have to exist. --- --- It gets more complicated if you take into account that the interface --- files are loaded lazily and that building multiple files at once has to --- work for any subset of interface files present. When you add parallelism --- this makes @Uniques@ hopelessly random. --- --- As such, to get deterministic builds, the order of the allocated --- @Uniques@ should not affect the final result. --- see also wiki/deterministic-builds --- --- Note [Unique Determinism and code generation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The goal of the deterministic builds (wiki/deterministic-builds, #4012) --- is to get ABI compatible binaries given the same inputs and environment. --- The motivation behind that is that if the ABI doesn't change the --- binaries can be safely reused. --- Note that this is weaker than bit-for-bit identical binaries and getting --- bit-for-bit identical binaries is not a goal for now. --- This means that we don't care about nondeterminism that happens after --- the interface files are created, in particular we don't care about --- register allocation and code generation. --- To track progress on bit-for-bit determinism see #12262. - -eqUnique :: Unique -> Unique -> Bool -eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 - -ltUnique :: Unique -> Unique -> Bool -ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 - --- Provided here to make it explicit at the call-site that it can --- introduce non-determinism. --- See Note [Unique Determinism] --- See Note [No Ord for Unique] -nonDetCmpUnique :: Unique -> Unique -> Ordering -nonDetCmpUnique (MkUnique u1) (MkUnique u2) - = if u1 == u2 then EQ else if u1 < u2 then LT else GT - -{- -Note [No Ord for Unique] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Unique Determinism] the relative order of Uniques -is nondeterministic. To prevent from accidental use the Ord Unique -instance has been removed. -This makes it easier to maintain deterministic builds, but comes with some -drawbacks. -The biggest drawback is that Maps keyed by Uniques can't directly be used. -The alternatives are: - - 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which - 2) Create a newtype wrapper based on Unique ordering where nondeterminism - is controlled. See Module.ModuleEnv - 3) Change the algorithm to use nonDetCmpUnique and document why it's still - deterministic - 4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel --} - -instance Eq Unique where - a == b = eqUnique a b - a /= b = not (eqUnique a b) - -instance Uniquable Unique where - getUnique u = u - --- We do sometimes make strings with @Uniques@ in them: - -showUnique :: Unique -> String -showUnique uniq - = case unpkUnique uniq of - (tag, u) -> finish_show tag u (iToBase62 u) - -finish_show :: Char -> Int -> String -> String -finish_show 't' u _pp_u | u < 26 - = -- Special case to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - [chr (ord 'a' + u)] -finish_show tag _ pp_u = tag : pp_u - -pprUniqueAlways :: Unique -> SDoc --- The "always" means regardless of -dsuppress-uniques --- It replaces the old pprUnique to remind callers that --- they should consider whether they want to consult --- Opt_SuppressUniques -pprUniqueAlways u - = text (showUnique u) - -instance Outputable Unique where - ppr = pprUniqueAlways - -instance Show Unique where - show uniq = showUnique uniq - -{- -************************************************************************ -* * -\subsection[Utils-base62]{Base-62 numbers} -* * -************************************************************************ - -A character-stingy way to read/write numbers (notably Uniques). -The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. -Code stolen from Lennart. --} - -iToBase62 :: Int -> String -iToBase62 n_ - = ASSERT(n_ >= 0) go n_ "" - where - go n cs | n < 62 - = let !c = chooseChar62 n in c : cs - | otherwise - = go q (c : cs) where (!q, r) = quotRem n 62 - !c = chooseChar62 r - - chooseChar62 :: Int -> Char - {-# INLINE chooseChar62 #-} - chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) - chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# - -{- -************************************************************************ -* * -\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} -* * -************************************************************************ - -Allocation of unique supply characters: - v,t,u : for renumbering value-, type- and usage- vars. - B: builtin - C-E: pseudo uniques (used in native-code generator) - X: uniques from mkLocalUnique - _: unifiable tyvars (above) - 0-9: prelude things below - (no numbers left any more..) - :: (prelude) parallel array data constructors - - other a-z: lower case chars for unique supplies. Used so far: - - d desugarer - f AbsC flattener - g SimplStg - k constraint tuple tycons - m constraint tuple datacons - n Native codegen - r Hsc name cache - s simplifier - z anonymous sums --} - -mkAlphaTyVarUnique :: Int -> Unique -mkPreludeClassUnique :: Int -> Unique -mkPreludeTyConUnique :: Int -> Unique -mkPreludeDataConUnique :: Arity -> Unique -mkPrimOpIdUnique :: Int -> Unique --- See Note [Primop wrappers] in PrimOp.hs. -mkPrimOpWrapperUnique :: Int -> Unique -mkPreludeMiscIdUnique :: Int -> Unique -mkCoVarUnique :: Int -> Unique - -mkAlphaTyVarUnique i = mkUnique '1' i -mkCoVarUnique i = mkUnique 'g' i -mkPreludeClassUnique i = mkUnique '2' i - --------------------------------------------------- --- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon -mkPreludeTyConUnique i = mkUnique '3' (2*i) - -tyConRepNameUnique :: Unique -> Unique -tyConRepNameUnique u = incrUnique u - --------------------------------------------------- --- Wired-in data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon --- Prelude data constructors are too simple to need wrappers. - -mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic - --------------------------------------------------- -dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique -dataConWorkerUnique u = incrUnique u -dataConTyRepNameUnique u = stepUnique u 2 - --------------------------------------------------- -mkPrimOpIdUnique op = mkUnique '9' (2*op) -mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) -mkPreludeMiscIdUnique i = mkUnique '0' i - --- The "tyvar uniques" print specially nicely: a, b, c, etc. --- See pprUnique for details - -initTyVarUnique :: Unique -initTyVarUnique = mkUnique 't' 0 - -mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, - mkBuiltinUnique :: Int -> Unique - -mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs -mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs -mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs - -mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkRegSingleUnique = mkUnique 'R' -mkRegSubUnique = mkUnique 'S' -mkRegPairUnique = mkUnique 'P' -mkRegClassUnique = mkUnique 'L' - -mkCostCentreUnique :: Int -> Unique -mkCostCentreUnique = mkUnique 'C' - -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique --- See Note [The Unique of an OccName] in OccName -mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) -mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) -mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) -mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) - -initExitJoinUnique :: Unique -initExitJoinUnique = mkUnique 's' 0 - diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs deleted file mode 100644 --- a/compiler/basicTypes/Var.hs +++ /dev/null @@ -1,763 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{@Vars@: Variables} --} - -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally --- potentially contain type variables, which have a 'TyCoRep.Kind' --- rather than a 'TyCoRep.Type' and only contain some extra --- details during typechecking. --- --- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" --- --- #globalvslocal# --- Global 'Id's and 'Var's are those that are imported or correspond --- to a data constructor, primitive operation, or record selectors. --- Local 'Id's and 'Var's are those bound within an expression --- (e.g. by a lambda) or at the top level of the module being compiled. - -module Var ( - -- * The main data type and synonyms - Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, - TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, - - -- * In and Out variants - InVar, InCoVar, InId, InTyVar, - OutVar, OutCoVar, OutId, OutTyVar, - - -- ** Taking 'Var's apart - varName, varUnique, varType, - - -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, updateVarType, - updateVarTypeM, - - -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, - idInfo, idDetails, - lazySetIdInfo, setIdDetails, globaliseId, - setIdExported, setIdNotExported, - - -- ** Predicates - isId, isTyVar, isTcTyVar, - isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, - isGlobalId, isExportedId, - mustHaveLocalBinding, - - -- * ArgFlags - ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, - AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, - - -- * TyVar's - VarBndr(..), TyCoVarBinder, TyVarBinder, - binderVar, binderVars, binderArgFlag, binderType, - mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinder, mkTyVarBinders, - isTyVarBinder, - - -- ** Constructing TyVar's - mkTyVar, mkTcTyVar, - - -- ** Taking 'TyVar's apart - tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, - - -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, - updateTyVarKindM, - - nonDetCmpVar - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep( Type, Kind ) -import {-# SOURCE #-} TyCoPpr( pprKind ) -import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, - vanillaIdInfo, pprIdDetails ) - -import Name hiding (varName) -import Unique ( Uniquable, Unique, getKey, getUnique - , mkUniqueGrimily, nonDetCmpUnique ) -import Util -import Binary -import Outputable - -import Data.Data - -{- -************************************************************************ -* * - Synonyms -* * -************************************************************************ --- These synonyms are here and not in Id because otherwise we need a very --- large number of SOURCE imports of Id.hs :-( --} - --- | Identifier -type Id = Var -- A term-level identifier - -- predicate: isId - --- | Coercion Variable -type CoVar = Id -- See Note [Evidence: EvIds and CoVars] - -- predicate: isCoVar - --- | -type NcId = Id -- A term-level (value) variable that is - -- /not/ an (unlifted) coercion - -- predicate: isNonCoVarId - --- | Type or kind Variable -type TyVar = Var -- Type *or* kind variable (historical) - --- | Type or Kind Variable -type TKVar = Var -- Type *or* kind variable (historical) - --- | Type variable that might be a metavariable -type TcTyVar = Var - --- | Type Variable -type TypeVar = Var -- Definitely a type variable - --- | Kind Variable -type KindVar = Var -- Definitely a kind variable - -- See Note [Kind and type variables] - --- See Note [Evidence: EvIds and CoVars] --- | Evidence Identifier -type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar - --- | Evidence Variable -type EvVar = EvId -- ...historical name for EvId - --- | Dictionary Function Identifier -type DFunId = Id -- A dictionary function - --- | Dictionary Identifier -type DictId = EvId -- A dictionary variable - --- | Implicit parameter Identifier -type IpId = EvId -- A term-level implicit parameter - --- | Equality Variable -type EqVar = EvId -- Boxed equality evidence -type JoinId = Id -- A join variable - --- | Type or Coercion Variable -type TyCoVar = Id -- Type, *or* coercion variable - -- predicate: isTyCoVar - - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied -} - -type InVar = Var -type InTyVar = TyVar -type InCoVar = CoVar -type InId = Id -type OutVar = Var -type OutTyVar = TyVar -type OutCoVar = CoVar -type OutId = Id - - - -{- Note [Evidence: EvIds and CoVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* An EvId (evidence Id) is a term-level evidence variable - (dictionary, implicit parameter, or equality). Could be boxed or unboxed. - -* DictId, IpId, and EqVar are synonyms when we know what kind of - evidence we are talking about. For example, an EqVar has type (t1 ~ t2). - -* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) - -Note [Kind and type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before kind polymorphism, TyVar were used to mean type variables. Now -they are used to mean kind *or* type variables. KindVar is used when we -know for sure that it is a kind variable. In future, we might want to -go over the whole compiler code to use: - - TKVar to mean kind or type variables - - TypeVar to mean type variables only - - KindVar to mean kind variables - - -************************************************************************ -* * -\subsection{The main data type declarations} -* * -************************************************************************ - - -Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a -@Type@, and an @IdInfo@ (non-essential info about it, e.g., -strictness). The essential info about different kinds of @Vars@ is -in its @VarDetails@. --} - --- | Variable --- --- Essentially a typed 'Name', that may also contain some additional information --- about the 'Var' and its use sites. -data Var - = TyVar { -- Type and kind variables - -- see Note [Kind and type variables] - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - -- ^ Key for fast comparison - -- Identical to the Unique in the name, - -- cached here for speed - varType :: Kind -- ^ The type or kind of the 'Var' in question - } - - | TcTyVar { -- Used only during type inference - -- Used for kind variables during - -- inference, as well - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Kind, - tc_tv_details :: TcTyVarDetails - } - - | Id { - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Type, - idScope :: IdScope, - id_details :: IdDetails, -- Stable, doesn't change - id_info :: IdInfo } -- Unstable, updated by simplifier - --- | Identifier Scope -data IdScope -- See Note [GlobalId/LocalId] - = GlobalId - | LocalId ExportFlag - -data ExportFlag -- See Note [ExportFlag on binders] - = NotExported -- ^ Not exported: may be discarded as dead code. - | Exported -- ^ Exported: kept alive - -{- Note [ExportFlag on binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An ExportFlag of "Exported" on a top-level binder says "keep this -binding alive; do not drop it as dead code". This transitively -keeps alive all the other top-level bindings that this binding refers -to. This property is persisted all the way down the pipeline, so that -the binding will be compiled all the way to object code, and its -symbols will appear in the linker symbol table. - -However, note that this use of "exported" is quite different to the -export list on a Haskell module. Setting the ExportFlag on an Id does -/not/ mean that if you import the module (in Haskell source code) you -will see this Id. Of course, things that appear in the export list -of the source Haskell module do indeed have their ExportFlag set. -But many other things, such as dictionary functions, are kept alive -by having their ExportFlag set, even though they are not exported -in the source-code sense. - -We should probably use a different term for ExportFlag, like -KeepAlive. - -Note [GlobalId/LocalId] -~~~~~~~~~~~~~~~~~~~~~~~ -A GlobalId is - * always a constant (top-level) - * imported, or data constructor, or primop, or record selector - * has a Unique that is globally unique across the whole - GHC invocation (a single invocation may compile multiple modules) - * never treated as a candidate by the free-variable finder; - it's a constant! - -A LocalId is - * bound within an expression (lambda, case, local let(rec)) - * or defined at top level in the module being compiled - * always treated as a candidate by the free-variable finder - -After CoreTidy, top-level LocalIds are turned into GlobalIds --} - -instance Outputable Var where - ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> - getPprStyle $ \ppr_style -> - if | debugStyle ppr_style && (not supp_var_kinds) - -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> - dcolon <+> pprKind (tyVarKind var)) - | otherwise - -> ppr (varName var) <> ppr_debug var ppr_style - -ppr_debug :: Var -> PprStyle -> SDoc -ppr_debug (TyVar {}) sty - | debugStyle sty = brackets (text "tv") -ppr_debug (TcTyVar {tc_tv_details = d}) sty - | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) -ppr_debug (Id { idScope = s, id_details = d }) sty - | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) -ppr_debug _ _ = empty - -ppr_id_scope :: IdScope -> SDoc -ppr_id_scope GlobalId = text "gid" -ppr_id_scope (LocalId Exported) = text "lidx" -ppr_id_scope (LocalId NotExported) = text "lid" - -instance NamedThing Var where - getName = varName - -instance Uniquable Var where - getUnique = varUnique - -instance Eq Var where - a == b = realUnique a == realUnique b - -instance Ord Var where - a <= b = realUnique a <= realUnique b - a < b = realUnique a < realUnique b - a >= b = realUnique a >= realUnique b - a > b = realUnique a > realUnique b - a `compare` b = a `nonDetCmpVar` b - --- | Compare Vars by their Uniques. --- This is what Ord Var does, provided here to make it explicit at the --- call-site that it can introduce non-determinism. --- See Note [Unique Determinism] -nonDetCmpVar :: Var -> Var -> Ordering -nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b - -instance Data Var where - -- don't traverse? - toConstr _ = abstractConstr "Var" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Var" - -instance HasOccName Var where - occName = nameOccName . varName - -varUnique :: Var -> Unique -varUnique var = mkUniqueGrimily (realUnique var) - -setVarUnique :: Var -> Unique -> Var -setVarUnique var uniq - = var { realUnique = getKey uniq, - varName = setNameUnique (varName var) uniq } - -setVarName :: Var -> Name -> Var -setVarName var new_name - = var { realUnique = getKey (getUnique new_name), - varName = new_name } - -setVarType :: Id -> Type -> Id -setVarType id ty = id { varType = ty } - -updateVarType :: (Type -> Type) -> Id -> Id -updateVarType f id = id { varType = f (varType id) } - -updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id -updateVarTypeM f id = do { ty' <- f (varType id) - ; return (id { varType = ty' }) } - -{- ********************************************************************* -* * -* ArgFlag -* * -********************************************************************* -} - --- | Argument Flag --- --- Is something required to appear in source Haskell ('Required'), --- permitted by request ('Specified') (visible type application), or --- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep -data ArgFlag = Inferred | Specified | Required - deriving (Eq, Ord, Data) - -- (<) on ArgFlag means "is less visible than" - --- | Does this 'ArgFlag' classify an argument that is written in Haskell? -isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag Required = True -isVisibleArgFlag _ = False - --- | Does this 'ArgFlag' classify an argument that is not written in Haskell? -isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag = not . isVisibleArgFlag - --- | Do these denote the same level of visibility? 'Required' --- arguments are visible, others are not. So this function --- equates 'Specified' and 'Inferred'. Used for printing. -sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis Required _ = False -sameVis _ Required = False -sameVis _ _ = True - -instance Outputable ArgFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance Binary ArgFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - --- | The non-dependent version of 'ArgFlag'. - --- Appears here partly so that it's together with its friend ArgFlag, --- but also because it is used in IfaceType, rather early in the --- compilation chain --- See Note [AnonArgFlag vs. ForallVisFlag] -data AnonArgFlag - = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. - -- The argument is visible in source code. - | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. - -- The argument is invisible in source code. - deriving (Eq, Ord, Data) - -instance Outputable AnonArgFlag where - ppr VisArg = text "[vis]" - ppr InvisArg = text "[invis]" - -instance Binary AnonArgFlag where - put_ bh VisArg = putByte bh 0 - put_ bh InvisArg = putByte bh 1 - - get bh = do - h <- getByte bh - case h of - 0 -> return VisArg - _ -> return InvisArg - --- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible --- (e.g., @forall a b -> {...}@, with an arrow)? - --- See Note [AnonArgFlag vs. ForallVisFlag] -data ForallVisFlag - = ForallVis -- ^ A visible @forall@ (with an arrow) - | ForallInvis -- ^ An invisible @forall@ (with a dot) - deriving (Eq, Ord, Data) - -instance Outputable ForallVisFlag where - ppr f = text $ case f of - ForallVis -> "ForallVis" - ForallInvis -> "ForallInvis" - --- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. -argToForallVisFlag :: ArgFlag -> ForallVisFlag -argToForallVisFlag Required = ForallVis -argToForallVisFlag Specified = ForallInvis -argToForallVisFlag Inferred = ForallInvis - -{- -Note [AnonArgFlag vs. ForallVisFlag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The AnonArgFlag and ForallVisFlag data types are quite similar at a first -glance: - - data AnonArgFlag = VisArg | InvisArg - data ForallVisFlag = ForallVis | ForallInvis - -Both data types keep track of visibility of some sort. AnonArgFlag tracks -whether a FunTy has a visible argument (->) or an invisible predicate argument -(=>). ForallVisFlag tracks whether a `forall` quantifier is visible -(forall a -> {...}) or invisible (forall a. {...}). - -Given their similarities, it's tempting to want to combine these two data types -into one, but they actually represent distinct concepts. AnonArgFlag reflects a -property of *Core* types, whereas ForallVisFlag reflects a property of the GHC -AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag -is all about surface syntax. Therefore, they are kept as separate data types. --} - -{- ********************************************************************* -* * -* VarBndr, TyCoVarBinder -* * -********************************************************************* -} - --- Variable Binder --- --- VarBndr is polymorphic in both var and visibility fields. --- Currently there are six different uses of 'VarBndr': --- * Var.TyVarBinder = VarBndr TyVar ArgFlag --- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag --- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis --- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis --- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag --- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -data VarBndr var argf = Bndr var argf - deriving( Data ) - --- | Variable Binder --- --- A 'TyCoVarBinder' is the binder of a ForAllTy --- It's convenient to define this synonym here rather its natural --- home in TyCoRep, because it's used in DataCon.hs-boot --- --- A 'TyVarBinder' is a binder with only TyVar -type TyCoVarBinder = VarBndr TyCoVar ArgFlag -type TyVarBinder = VarBndr TyVar ArgFlag - -binderVar :: VarBndr tv argf -> tv -binderVar (Bndr v _) = v - -binderVars :: [VarBndr tv argf] -> [tv] -binderVars tvbs = map binderVar tvbs - -binderArgFlag :: VarBndr tv argf -> argf -binderArgFlag (Bndr _ argf) = argf - -binderType :: VarBndr TyCoVar argf -> Type -binderType (Bndr tv _) = varType tv - --- | Make a named binder -mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder -mkTyCoVarBinder vis var = Bndr var vis - --- | Make a named binder --- 'var' should be a type variable -mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder -mkTyVarBinder vis var - = ASSERT( isTyVar var ) - Bndr var vis - --- | Make many named binders -mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] -mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) - --- | Make many named binders --- Input vars should be type variables -mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] -mkTyVarBinders vis = map (mkTyVarBinder vis) - -isTyVarBinder :: TyCoVarBinder -> Bool -isTyVarBinder (Bndr v _) = isTyVar v - -instance Outputable tv => Outputable (VarBndr tv ArgFlag) where - ppr (Bndr v Required) = ppr v - ppr (Bndr v Specified) = char '@' <> ppr v - ppr (Bndr v Inferred) = braces (ppr v) - -instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where - put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } - - get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } - -instance NamedThing tv => NamedThing (VarBndr tv flag) where - getName (Bndr tv _) = getName tv - -{- -************************************************************************ -* * -* Type and kind variables * -* * -************************************************************************ --} - -tyVarName :: TyVar -> Name -tyVarName = varName - -tyVarKind :: TyVar -> Kind -tyVarKind = varType - -setTyVarUnique :: TyVar -> Unique -> TyVar -setTyVarUnique = setVarUnique - -setTyVarName :: TyVar -> Name -> TyVar -setTyVarName = setVarName - -setTyVarKind :: TyVar -> Kind -> TyVar -setTyVarKind tv k = tv {varType = k} - -updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar -updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} - -updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar -updateTyVarKindM update tv - = do { k' <- update (tyVarKind tv) - ; return $ tv {varType = k'} } - -mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = TyVar { varName = name - , realUnique = getKey (nameUnique name) - , varType = kind - } - -mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar -mkTcTyVar name kind details - = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' - TcTyVar { varName = name, - realUnique = getKey (nameUnique name), - varType = kind, - tc_tv_details = details - } - -tcTyVarDetails :: TyVar -> TcTyVarDetails --- See Note [TcTyVars in the typechecker] in TcType -tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details -tcTyVarDetails (TyVar {}) = vanillaSkolemTv -tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) - -setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar -setTcTyVarDetails tv details = tv { tc_tv_details = details } - -{- -%************************************************************************ -%* * -\subsection{Ids} -* * -************************************************************************ --} - -idInfo :: HasDebugCallStack => Id -> IdInfo -idInfo (Id { id_info = info }) = info -idInfo other = pprPanic "idInfo" (ppr other) - -idDetails :: Id -> IdDetails -idDetails (Id { id_details = details }) = details -idDetails other = pprPanic "idDetails" (ppr other) - --- The next three have a 'Var' suffix even though they always build --- Ids, because Id.hs uses 'mkGlobalId' etc with different types -mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalVar details name ty info - = mk_id name ty GlobalId details info - -mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkLocalVar details name ty info - = mk_id name ty (LocalId NotExported) details info - -mkCoVar :: Name -> Type -> CoVar --- Coercion variables have no IdInfo -mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo - --- | Exported 'Var's will not be removed as dead code -mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkExportedLocalVar details name ty info - = mk_id name ty (LocalId Exported) details info - -mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name ty scope details info - = Id { varName = name, - realUnique = getKey (nameUnique name), - varType = ty, - idScope = scope, - id_details = details, - id_info = info } - -------------------- -lazySetIdInfo :: Id -> IdInfo -> Var -lazySetIdInfo id info = id { id_info = info } - -setIdDetails :: Id -> IdDetails -> Id -setIdDetails id details = id { id_details = details } - -globaliseId :: Id -> Id --- ^ If it's a local, make it global -globaliseId id = id { idScope = GlobalId } - -setIdExported :: Id -> Id --- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors --- and class operations, which are born as global 'Id's and automatically exported -setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } -setIdExported id@(Id { idScope = GlobalId }) = id -setIdExported tv = pprPanic "setIdExported" (ppr tv) - -setIdNotExported :: Id -> Id --- ^ We can only do this to LocalIds -setIdNotExported id = ASSERT( isLocalId id ) - id { idScope = LocalId NotExported } - -{- -************************************************************************ -* * -\subsection{Predicates over variables} -* * -************************************************************************ --} - --- | Is this a type-level (i.e., computationally irrelevant, thus erasable) --- variable? Satisfies @isTyVar = not . isId@. -isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False - -isTcTyVar :: Var -> Bool -- True of TcTyVar only -isTcTyVar (TcTyVar {}) = True -isTcTyVar _ = False - -isTyCoVar :: Var -> Bool -isTyCoVar v = isTyVar v || isCoVar v - --- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? --- Satisfies @isId = not . isTyVar@. -isId :: Var -> Bool -isId (Id {}) = True -isId _ = False - --- | Is this a coercion variable? --- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. -isCoVar :: Var -> Bool -isCoVar (Id { id_details = details }) = isCoVarDetails details -isCoVar _ = False - --- | Is this a term variable ('Id') that is /not/ a coercion variable? --- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. -isNonCoVarId :: Var -> Bool -isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) -isNonCoVarId _ = False - -isLocalId :: Var -> Bool -isLocalId (Id { idScope = LocalId _ }) = True -isLocalId _ = False - --- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's --- These are the variables that we need to pay attention to when finding free --- variables, or doing dependency analysis. -isLocalVar :: Var -> Bool -isLocalVar v = not (isGlobalId v) - -isGlobalId :: Var -> Bool -isGlobalId (Id { idScope = GlobalId }) = True -isGlobalId _ = False - --- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's --- that must have a binding in this module. The converse --- is not quite right: there are some global 'Id's that must have --- bindings, such as record selectors. But that doesn't matter, --- because it's only used for assertions -mustHaveLocalBinding :: Var -> Bool -mustHaveLocalBinding var = isLocalVar var - --- | 'isExportedIdVar' means \"don't throw this away\" -isExportedId :: Var -> Bool -isExportedId (Id { idScope = GlobalId }) = True -isExportedId (Id { idScope = LocalId Exported}) = True -isExportedId _ = False diff --git a/compiler/basicTypes/Var.hs-boot b/compiler/basicTypes/Var.hs-boot deleted file mode 100644 --- a/compiler/basicTypes/Var.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ --- Var.hs-boot is Imported (only) by TyCoRep.hs-boot -module Var where - -import GhcPrelude () - -- We compile this module with -XNoImplicitPrelude (for some - -- reason), so if there are no imports it does not seem to - -- depend on anything. But it does! We must, for example, - -- compile GHC.Types in the ghc-prim library first. - -- So this otherwise-unnecessary import tells the build system - -- that this module depends on GhcPrelude, which ensures - -- that GHC.Type is built first. - -data ArgFlag -data AnonArgFlag -data Var diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs deleted file mode 100644 --- a/compiler/basicTypes/VarEnv.hs +++ /dev/null @@ -1,632 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module VarEnv ( - -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, - - -- ** Manipulating these environments - emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, - elemVarEnv, disjointVarEnv, - extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, - extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, - plusVarEnvList, alterVarEnv, - delVarEnvList, delVarEnv, delVarEnv_Directly, - minusVarEnv, intersectsVarEnv, - lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, - mapVarEnv, zipVarEnv, - modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, - elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv, filterVarEnv_Directly, restrictVarEnv, - partitionVarEnv, - - -- * Deterministic Var environments (maps) - DVarEnv, DIdEnv, DTyVarEnv, - - -- ** Manipulating these environments - emptyDVarEnv, mkDVarEnv, - dVarEnvElts, - extendDVarEnv, extendDVarEnv_C, - extendDVarEnvList, - lookupDVarEnv, elemDVarEnv, - isEmptyDVarEnv, foldDVarEnv, - mapDVarEnv, filterDVarEnv, - modifyDVarEnv, - alterDVarEnv, - plusDVarEnv, plusDVarEnv_C, - unitDVarEnv, - delDVarEnv, - delDVarEnvList, - minusDVarEnv, - partitionDVarEnv, - anyDVarEnv, - - -- * The InScopeSet type - InScopeSet, - - -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, - varSetInScope, - unsafeGetFreshLocalUnique, - - -- * The RnEnv2 type - RnEnv2, - - -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, - rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, - delBndrL, delBndrR, delBndrsL, delBndrsR, - addRnInScopeSet, - rnEtaL, rnEtaR, - rnInScope, rnInScopeSet, lookupRnInScope, - rnEnvL, rnEnvR, - - -- * TidyEnv and its operation - TidyEnv, - emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList - ) where - -import GhcPrelude -import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM - -import OccName -import Name -import Var -import VarSet -import UniqSet -import UniqFM -import UniqDFM -import Unique -import Util -import Maybes -import Outputable - -{- -************************************************************************ -* * - In-scope sets -* * -************************************************************************ --} - --- | A set of variables that are in scope at some point --- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides --- the motivation for this abstraction. -newtype InScopeSet = InScope VarSet - -- Note [Lookups in in-scope set] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- We store a VarSet here, but we use this for lookups rather than just - -- membership tests. Typically the InScopeSet contains the canonical - -- version of the variable (e.g. with an informative unfolding), so this - -- lookup is useful (see, for instance, Note [In-scope set as a - -- substitution]). - -instance Outputable InScopeSet where - ppr (InScope s) = - text "InScope" <+> - braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) - -- It's OK to use nonDetEltsUniqSet here because it's - -- only for pretty printing - -- In-scope sets get big, and with -dppr-debug - -- the output is overwhelming - -emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet - -getInScopeVars :: InScopeSet -> VarSet -getInScopeVars (InScope vs) = vs - -mkInScopeSet :: VarSet -> InScopeSet -mkInScopeSet in_scope = InScope in_scope - -extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope) v - = InScope (extendVarSet in_scope v) - -extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope) vs - = InScope $ foldl' extendVarSet in_scope vs - -extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet -extendInScopeSetSet (InScope in_scope) vs - = InScope (in_scope `unionVarSet` vs) - -delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) - -elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope - --- | Look up a variable the 'InScopeSet'. This lets you map from --- the variable's identity (unique) to its full value. -lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope) v = lookupVarSet in_scope v - -lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var -lookupInScope_Directly (InScope in_scope) uniq - = lookupVarSet_Directly in_scope uniq - -unionInScope :: InScopeSet -> InScopeSet -> InScopeSet -unionInScope (InScope s1) (InScope s2) - = InScope (s1 `unionVarSet` s2) - -varSetInScope :: VarSet -> InScopeSet -> Bool -varSetInScope vars (InScope s1) = vars `subVarSet` s1 - -{- -Note [Local uniques] -~~~~~~~~~~~~~~~~~~~~ -Sometimes one must create conjure up a unique which is unique in a particular -context (but not necessarily globally unique). For instance, one might need to -create a fresh local identifier which does not shadow any of the locally -in-scope variables. For this we purpose we provide 'uniqAway'. - -'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' -operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To -ensure that we do not conflict with uniques allocated by future allocations -from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are -allocated into a dedicated region of the unique space (namely the X tag). - -Note that one must be quite carefully when using uniques generated in this way -since they are only locally unique. In particular, two successive calls to -'uniqAway' on the same 'InScopeSet' will produce the same unique. - -} - --- | @uniqAway in_scope v@ finds a unique that is not used in the --- in-scope set, and gives that to v. See Note [Local uniques]. -uniqAway :: InScopeSet -> Var -> Var --- It starts with v's current unique, of course, in the hope that it won't --- have to change, and thereafter uses the successor to the last derived unique --- found in the in-scope set. -uniqAway in_scope var - | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one - | otherwise = var -- Nothing to do - -uniqAway' :: InScopeSet -> Var -> Var --- This one *always* makes up a new variable -uniqAway' in_scope var - = setVarUnique var (unsafeGetFreshLocalUnique in_scope) - --- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the --- given 'InScopeSet'. This must be used very carefully since one can very easily --- introduce non-unique 'Unique's this way. See Note [Local uniques]. -unsafeGetFreshLocalUnique :: InScopeSet -> Unique -unsafeGetFreshLocalUnique (InScope set) - | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) - , let uniq' = mkLocalUnique uniq - , not $ uniq' `ltUnique` minLocalUnique - = incrUnique uniq' - - | otherwise - = minLocalUnique - -{- -************************************************************************ -* * - Dual renaming -* * -************************************************************************ --} - --- | Rename Environment 2 --- --- When we are comparing (or matching) types or terms, we are faced with --- \"going under\" corresponding binders. E.g. when comparing: --- --- > \x. e1 ~ \y. e2 --- --- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of --- things we must be careful of. In particular, @x@ might be free in @e2@, or --- y in @e1@. So the idea is that we come up with a fresh binder that is free --- in neither, and rename @x@ and @y@ respectively. That means we must maintain: --- --- 1. A renaming for the left-hand expression --- --- 2. A renaming for the right-hand expressions --- --- 3. An in-scope set --- --- Furthermore, when matching, we want to be able to have an 'occurs check', --- to prevent: --- --- > \x. f ~ \y. y --- --- matching with [@f@ -> @y@]. So for each expression we want to know that set of --- locally-bound variables. That is precisely the domain of the mappings 1. --- and 2., but we must ensure that we always extend the mappings as we go in. --- --- All of this information is bundled up in the 'RnEnv2' -data RnEnv2 - = RV2 { envL :: VarEnv Var -- Renaming for Left term - , envR :: VarEnv Var -- Renaming for Right term - , in_scope :: InScopeSet } -- In scope in left or right terms - --- The renamings envL and envR are *guaranteed* to contain a binding --- for every variable bound as we go into the term, even if it is not --- renamed. That way we can ask what variables are locally bound --- (inRnEnvL, inRnEnvR) - -mkRnEnv2 :: InScopeSet -> RnEnv2 -mkRnEnv2 vars = RV2 { envL = emptyVarEnv - , envR = emptyVarEnv - , in_scope = vars } - -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 -addRnInScopeSet env vs - | isEmptyVarSet vs = env - | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } - -rnInScope :: Var -> RnEnv2 -> Bool -rnInScope x env = x `elemInScopeSet` in_scope env - -rnInScopeSet :: RnEnv2 -> InScopeSet -rnInScopeSet = in_scope - --- | Retrieve the left mapping -rnEnvL :: RnEnv2 -> VarEnv Var -rnEnvL = envL - --- | Retrieve the right mapping -rnEnvR :: RnEnv2 -> VarEnv Var -rnEnvR = envR - -rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 --- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length -rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR - -rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 --- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, --- and binder @bR@ in the Right term. --- It finds a new binder, @new_b@, --- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ -rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR - -rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but returns the new variable as well as the --- new environment -rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = (RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - -- Find a new binder not in scope in either term - new_b | not (bL `elemInScopeSet` in_scope) = bL - | not (bR `elemInScopeSet` in_scope) = bR - | otherwise = uniqAway' in_scope bL - - -- Note [Rebinding] - -- If the new var is the same as the old one, note that - -- the extendVarEnv *deletes* any current renaming - -- E.g. (\x. \x. ...) ~ (\y. \z. ...) - -- - -- Inside \x \y { [x->y], [y->y], {y} } - -- \x \z { [x->x], [y->y, z->x], {y,x} } - -rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the left --- side only. -rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = envR - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the right --- side only. -rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envR = extendVarEnv envR bR new_b - , envL = envL - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndrL' but used for eta expansion --- See Note [Eta expansion] -rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used for eta expansion --- See Note [Eta expansion] -rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] - , envR = extendVarEnv envR bR new_b - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 -delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } -delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } - -delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 -delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } -delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } - -rnOccL, rnOccR :: RnEnv2 -> Var -> Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v -rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v - -rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v -rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v - -inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool --- ^ Tells whether a variable is locally bound -inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env -inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env - -lookupRnInScope :: RnEnv2 -> Var -> Var -lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v - -nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 --- ^ Wipe the left or right side renaming -nukeRnEnvL env = env { envL = emptyVarEnv } -nukeRnEnvR env = env { envR = emptyVarEnv } - -rnSwap :: RnEnv2 -> RnEnv2 --- ^ swap the meaning of left and right -rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) - = RV2 { envL = envR, envR = envL, in_scope = in_scope } - -{- -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~ -When matching - (\x.M) ~ N -we rename x to x' with, where x' is not in scope in -either term. Then we want to behave as if we'd seen - (\x'.M) ~ (\x'.N x') -Since x' isn't in scope in N, the form (\x'. N x') doesn't -capture any variables in N. But we must nevertheless extend -the envR with a binding [x' -> x'], to support the occurs check. -For example, if we don't do this, we can get silly matches like - forall a. (\y.a) ~ v -succeeding with [a -> v y], which is bogus of course. - - -************************************************************************ -* * - Tidying -* * -************************************************************************ --} - --- | Tidy Environment --- --- When tidying up print names, we keep a mapping of in-scope occ-names --- (the 'TidyOccEnv') and a Var-to-Var of the current renamings -type TidyEnv = (TidyOccEnv, VarEnv Var) - -emptyTidyEnv :: TidyEnv -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) - -mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv -mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) - -delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv -delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') - where - occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs - var_env' = var_env `delVarEnvList` vs - -{- -************************************************************************ -* * -\subsection{@VarEnv@s} -* * -************************************************************************ --} - --- | Variable Environment -type VarEnv elt = UniqFM elt - --- | Identifier Environment -type IdEnv elt = VarEnv elt - --- | Type Variable Environment -type TyVarEnv elt = VarEnv elt - --- | Type or Coercion Variable Environment -type TyCoVarEnv elt = VarEnv elt - --- | Coercion Variable Environment -type CoVarEnv elt = VarEnv elt - -emptyVarEnv :: VarEnv a -mkVarEnv :: [(Var, a)] -> VarEnv a -mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a -zipVarEnv :: [Var] -> [a] -> VarEnv a -unitVarEnv :: Var -> a -> VarEnv a -alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a -extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b -extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a -plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -plusVarEnvList :: [VarEnv a] -> VarEnv a -extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a - -lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a -filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a -delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a -partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a -delVarEnvList :: VarEnv a -> [Var] -> VarEnv a -delVarEnv :: VarEnv a -> Var -> VarEnv a -minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a -intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool -plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a -plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a -plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a -mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a - -isEmptyVarEnv :: VarEnv a -> Bool -lookupVarEnv :: VarEnv a -> Var -> Maybe a -filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a -lookupVarEnv_NF :: VarEnv a -> Var -> a -lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a -elemVarEnv :: Var -> VarEnv a -> Bool -elemVarEnvByKey :: Unique -> VarEnv a -> Bool -disjointVarEnv :: VarEnv a -> VarEnv a -> Bool - -elemVarEnv = elemUFM -elemVarEnvByKey = elemUFM_Directly -disjointVarEnv = disjointUFM -alterVarEnv = alterUFM -extendVarEnv = addToUFM -extendVarEnv_C = addToUFM_C -extendVarEnv_Acc = addToUFM_Acc -extendVarEnv_Directly = addToUFM_Directly -extendVarEnvList = addListToUFM -plusVarEnv_C = plusUFM_C -plusVarEnv_CD = plusUFM_CD -plusMaybeVarEnv_C = plusMaybeUFM_C -delVarEnvList = delListFromUFM -delVarEnv = delFromUFM -minusVarEnv = minusUFM -intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) -plusVarEnv = plusUFM -plusVarEnvList = plusUFMList -lookupVarEnv = lookupUFM -filterVarEnv = filterUFM -lookupWithDefaultVarEnv = lookupWithDefaultUFM -mapVarEnv = mapUFM -mkVarEnv = listToUFM -mkVarEnv_Directly= listToUFM_Directly -emptyVarEnv = emptyUFM -unitVarEnv = unitUFM -isEmptyVarEnv = isNullUFM -lookupVarEnv_Directly = lookupUFM_Directly -filterVarEnv_Directly = filterUFM_Directly -delVarEnv_Directly = delFromUFM_Directly -partitionVarEnv = partitionUFM - -restrictVarEnv env vs = filterVarEnv_Directly keep env - where - keep u _ = u `elemVarSetByKey` vs - -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case lookupVarEnv env id of - Just xx -> xx - Nothing -> panic "lookupVarEnv_NF: Nothing" - -{- -@modifyVarEnv@: Look up a thing in the VarEnv, -then mash it with the modify function, and put it back. --} - -modifyVarEnv mangle_fn env key - = case (lookupVarEnv env key) of - Nothing -> env - Just xx -> extendVarEnv env key (mangle_fn xx) - -modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a -modifyVarEnv_Directly mangle_fn env key - = case (lookupUFM_Directly env key) of - Nothing -> env - Just xx -> addToUFM_Directly env key (mangle_fn xx) - --- Deterministic VarEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarEnv. - --- | Deterministic Variable Environment -type DVarEnv elt = UniqDFM elt - --- | Deterministic Identifier Environment -type DIdEnv elt = DVarEnv elt - --- | Deterministic Type Variable Environment -type DTyVarEnv elt = DVarEnv elt - -emptyDVarEnv :: DVarEnv a -emptyDVarEnv = emptyUDFM - -dVarEnvElts :: DVarEnv a -> [a] -dVarEnvElts = eltsUDFM - -mkDVarEnv :: [(Var, a)] -> DVarEnv a -mkDVarEnv = listToUDFM - -extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv = addToUDFM - -minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a -minusDVarEnv = minusUDFM - -lookupDVarEnv :: DVarEnv a -> Var -> Maybe a -lookupDVarEnv = lookupUDFM - -foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b -foldDVarEnv = foldUDFM - -mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b -mapDVarEnv = mapUDFM - -filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a -filterDVarEnv = filterUDFM - -alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a -alterDVarEnv = alterUDFM - -plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv = plusUDFM - -plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv_C = plusUDFM_C - -unitDVarEnv :: Var -> a -> DVarEnv a -unitDVarEnv = unitUDFM - -delDVarEnv :: DVarEnv a -> Var -> DVarEnv a -delDVarEnv = delFromUDFM - -delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a -delDVarEnvList = delListFromUDFM - -isEmptyDVarEnv :: DVarEnv a -> Bool -isEmptyDVarEnv = isNullUDFM - -elemDVarEnv :: Var -> DVarEnv a -> Bool -elemDVarEnv = elemUDFM - -extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv_C = addToUDFM_C - -modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a -modifyDVarEnv mangle_fn env key - = case (lookupDVarEnv env key) of - Nothing -> env - Just xx -> extendDVarEnv env key (mangle_fn xx) - -partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) -partitionDVarEnv = partitionUDFM - -extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a -extendDVarEnvList = addListToUDFM - -anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool -anyDVarEnv = anyUDFM diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs deleted file mode 100644 --- a/compiler/basicTypes/VarSet.hs +++ /dev/null @@ -1,354 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -module VarSet ( - -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, - - -- ** Manipulating these sets - emptyVarSet, unitVarSet, mkVarSet, - extendVarSet, extendVarSetList, - elemVarSet, subVarSet, - unionVarSet, unionVarSets, mapUnionVarSet, - intersectVarSet, intersectsVarSet, disjointVarSet, - isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, - minusVarSet, filterVarSet, mapVarSet, - anyVarSet, allVarSet, - transCloVarSet, fixVarSet, - lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, - sizeVarSet, seqVarSet, - elemVarSetByKey, partitionVarSet, - pluralVarSet, pprVarSet, - nonDetFoldVarSet, - - -- * Deterministic Var set types - DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, - - -- ** Manipulating these sets - emptyDVarSet, unitDVarSet, mkDVarSet, - extendDVarSet, extendDVarSetList, - elemDVarSet, dVarSetElems, subDVarSet, - unionDVarSet, unionDVarSets, mapUnionDVarSet, - intersectDVarSet, dVarSetIntersectVarSet, - intersectsDVarSet, disjointDVarSet, - isEmptyDVarSet, delDVarSet, delDVarSetList, - minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, - dVarSetMinusVarSet, anyDVarSet, allDVarSet, - transCloDVarSet, - sizeDVarSet, seqDVarSet, - partitionDVarSet, - dVarSetToVarSet, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Var ( Var, TyVar, CoVar, TyCoVar, Id ) -import Unique -import Name ( Name ) -import UniqSet -import UniqDSet -import UniqFM( disjointUFM, pluralUFM, pprUFM ) -import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) -import Outputable (SDoc) - --- | A non-deterministic Variable Set --- --- A non-deterministic set of variables. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not --- deterministic and why it matters. Use DVarSet if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code, for example when abstracting variables. -type VarSet = UniqSet Var - --- | Identifier Set -type IdSet = UniqSet Id - --- | Type Variable Set -type TyVarSet = UniqSet TyVar - --- | Coercion Variable Set -type CoVarSet = UniqSet CoVar - --- | Type or Coercion Variable Set -type TyCoVarSet = UniqSet TyCoVar - -emptyVarSet :: VarSet -intersectVarSet :: VarSet -> VarSet -> VarSet -unionVarSet :: VarSet -> VarSet -> VarSet -unionVarSets :: [VarSet] -> VarSet - -mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet --- ^ map the function over the list, and union the results - -unitVarSet :: Var -> VarSet -extendVarSet :: VarSet -> Var -> VarSet -extendVarSetList:: VarSet -> [Var] -> VarSet -elemVarSet :: Var -> VarSet -> Bool -delVarSet :: VarSet -> Var -> VarSet -delVarSetList :: VarSet -> [Var] -> VarSet -minusVarSet :: VarSet -> VarSet -> VarSet -isEmptyVarSet :: VarSet -> Bool -mkVarSet :: [Var] -> VarSet -lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var -lookupVarSet :: VarSet -> Var -> Maybe Var - -- Returns the set element, which may be - -- (==) to the argument, but not the same as -lookupVarSetByName :: VarSet -> Name -> Maybe Var -sizeVarSet :: VarSet -> Int -filterVarSet :: (Var -> Bool) -> VarSet -> VarSet - -delVarSetByKey :: VarSet -> Unique -> VarSet -elemVarSetByKey :: Unique -> VarSet -> Bool -partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) - -emptyVarSet = emptyUniqSet -unitVarSet = unitUniqSet -extendVarSet = addOneToUniqSet -extendVarSetList= addListToUniqSet -intersectVarSet = intersectUniqSets - -intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection -disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection -subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second - -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; - -- ditto disjointVarSet, subVarSet - -unionVarSet = unionUniqSets -unionVarSets = unionManyUniqSets -elemVarSet = elementOfUniqSet -minusVarSet = minusUniqSet -delVarSet = delOneFromUniqSet -delVarSetList = delListFromUniqSet -isEmptyVarSet = isEmptyUniqSet -mkVarSet = mkUniqSet -lookupVarSet_Directly = lookupUniqSet_Directly -lookupVarSet = lookupUniqSet -lookupVarSetByName = lookupUniqSet -sizeVarSet = sizeUniqSet -filterVarSet = filterUniqSet -delVarSetByKey = delOneFromUniqSet_Directly -elemVarSetByKey = elemUniqSet_Directly -partitionVarSet = partitionUniqSet - -mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs - --- See comments with type signatures -intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) -disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) -subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) - -anyVarSet :: (Var -> Bool) -> VarSet -> Bool -anyVarSet = uniqSetAny - -allVarSet :: (Var -> Bool) -> VarSet -> Bool -allVarSet = uniqSetAll - -mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b -mapVarSet = mapUniqSet - -nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a -nonDetFoldVarSet = nonDetFoldUniqSet - -fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set - -> VarSet -> VarSet --- (fixVarSet f s) repeatedly applies f to the set s, --- until it reaches a fixed point. -fixVarSet fn vars - | new_vars `subVarSet` vars = vars - | otherwise = fixVarSet fn new_vars - where - new_vars = fn vars - -transCloVarSet :: (VarSet -> VarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> VarSet -> VarSet --- (transCloVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 --- Use fixVarSet if the function needs to see the whole set all at once -transCloVarSet fn seeds - = go seeds seeds - where - go :: VarSet -- Accumulating result - -> VarSet -- Work-list; un-processed subset of accumulating result - -> VarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyVarSet new_vs = acc - | otherwise = go (acc `unionVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusVarSet` acc - -seqVarSet :: VarSet -> () -seqVarSet s = sizeVarSet s `seq` () - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralVarSet :: VarSet -> SDoc -pluralVarSet = pluralUFM . getUniqSet - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. --- Passing a list to the pretty-printing function allows the caller --- to decide on the order of Vars (eg. toposort them) without them having --- to use nonDetEltsUFM at the call site. This prevents from let-binding --- non-deterministically ordered lists and reusing them where determinism --- matters. -pprVarSet :: VarSet -- ^ The things to be pretty printed - -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the - -- elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprVarSet = pprUFM . getUniqSet - --- Deterministic VarSet --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarSet. - --- | Deterministic Variable Set -type DVarSet = UniqDSet Var - --- | Deterministic Identifier Set -type DIdSet = UniqDSet Id - --- | Deterministic Type Variable Set -type DTyVarSet = UniqDSet TyVar - --- | Deterministic Type or Coercion Variable Set -type DTyCoVarSet = UniqDSet TyCoVar - -emptyDVarSet :: DVarSet -emptyDVarSet = emptyUniqDSet - -unitDVarSet :: Var -> DVarSet -unitDVarSet = unitUniqDSet - -mkDVarSet :: [Var] -> DVarSet -mkDVarSet = mkUniqDSet - --- The new element always goes to the right of existing ones. -extendDVarSet :: DVarSet -> Var -> DVarSet -extendDVarSet = addOneToUniqDSet - -elemDVarSet :: Var -> DVarSet -> Bool -elemDVarSet = elementOfUniqDSet - -dVarSetElems :: DVarSet -> [Var] -dVarSetElems = uniqDSetToList - -subDVarSet :: DVarSet -> DVarSet -> Bool -subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) - -unionDVarSet :: DVarSet -> DVarSet -> DVarSet -unionDVarSet = unionUniqDSets - -unionDVarSets :: [DVarSet] -> DVarSet -unionDVarSets = unionManyUniqDSets - --- | Map the function over the list, and union the results -mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet -mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs - -intersectDVarSet :: DVarSet -> DVarSet -> DVarSet -intersectDVarSet = intersectUniqDSets - -dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetIntersectVarSet = uniqDSetIntersectUniqSet - --- | True if empty intersection -disjointDVarSet :: DVarSet -> DVarSet -> Bool -disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) - --- | True if non-empty intersection -intersectsDVarSet :: DVarSet -> DVarSet -> Bool -intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) - -isEmptyDVarSet :: DVarSet -> Bool -isEmptyDVarSet = isEmptyUniqDSet - -delDVarSet :: DVarSet -> Var -> DVarSet -delDVarSet = delOneFromUniqDSet - -minusDVarSet :: DVarSet -> DVarSet -> DVarSet -minusDVarSet = minusUniqDSet - -dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetMinusVarSet = uniqDSetMinusUniqSet - -foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a -foldDVarSet = foldUniqDSet - -anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool -anyDVarSet p = anyUDFM p . getUniqDSet - -allDVarSet :: (Var -> Bool) -> DVarSet -> Bool -allDVarSet p = allUDFM p . getUniqDSet - -mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapDVarSet = mapUniqDSet - -filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet -filterDVarSet = filterUniqDSet - -sizeDVarSet :: DVarSet -> Int -sizeDVarSet = sizeUniqDSet - --- | Partition DVarSet according to the predicate given -partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) -partitionDVarSet = partitionUniqDSet - --- | Delete a list of variables from DVarSet -delDVarSetList :: DVarSet -> [Var] -> DVarSet -delDVarSetList = delListFromUniqDSet - -seqDVarSet :: DVarSet -> () -seqDVarSet s = sizeDVarSet s `seq` () - --- | Add a list of variables to DVarSet -extendDVarSetList :: DVarSet -> [Var] -> DVarSet -extendDVarSetList = addListToUniqDSet - --- | Convert a DVarSet to a VarSet by forgetting the order of insertion -dVarSetToVarSet :: DVarSet -> VarSet -dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet - --- | transCloVarSet for DVarSet -transCloDVarSet :: (DVarSet -> DVarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> DVarSet -> DVarSet --- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 -transCloDVarSet fn seeds - = go seeds seeds - where - go :: DVarSet -- Accumulating result - -> DVarSet -- Work-list; un-processed subset of accumulating result - -> DVarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyDVarSet new_vs = acc - | otherwise = go (acc `unionDVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusDVarSet` acc diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs --- a/compiler/iface/BinFingerprint.hs +++ b/compiler/iface/BinFingerprint.hs @@ -14,7 +14,7 @@ import Fingerprint import Binary -import Name +import GHC.Types.Name import PlainPanic import Util diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs deleted file mode 100644 --- a/compiler/main/Annotations.hs +++ /dev/null @@ -1,148 +0,0 @@ --- | --- Support for source code annotation feature of GHC. That is the ANN pragma. --- --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- -{-# LANGUAGE DeriveFunctor #-} -module Annotations ( - -- * Main Annotation data types - Annotation(..), AnnPayload, - AnnTarget(..), CoreAnnTarget, - getAnnTargetName_maybe, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, - findAnns, findAnnsByTypeRep, - deserializeAnns - ) where - -import GhcPrelude - -import Binary -import Module ( Module - , ModuleEnv, emptyModuleEnv, extendModuleEnvWith - , plusModuleEnv_C, lookupWithDefaultModuleEnv - , mapModuleEnv ) -import NameEnv -import Name -import Outputable -import GHC.Serialized - -import Control.Monad -import Data.Maybe -import Data.Typeable -import Data.Word ( Word8 ) - - --- | Represents an annotation after it has been sufficiently desugared from --- it's initial form of 'HsDecls.AnnDecl' -data Annotation = Annotation { - ann_target :: CoreAnnTarget, -- ^ The target of the annotation - ann_value :: AnnPayload - } - -type AnnPayload = Serialized -- ^ The "payload" of an annotation - -- allows recovery of its value at a given type, - -- and can be persisted to an interface file - --- | An annotation target -data AnnTarget name - = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier - | ModuleTarget Module -- ^ We are annotating a particular module - deriving (Functor) - --- | The kind of annotation target found in the middle end of the compiler -type CoreAnnTarget = AnnTarget Name - --- | Get the 'name' of an annotation target if it exists. -getAnnTargetName_maybe :: AnnTarget name -> Maybe name -getAnnTargetName_maybe (NamedTarget nm) = Just nm -getAnnTargetName_maybe _ = Nothing - -instance Outputable name => Outputable (AnnTarget name) where - ppr (NamedTarget nm) = text "Named target" <+> ppr nm - ppr (ModuleTarget mod) = text "Module target" <+> ppr mod - -instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh - case h of - 0 -> liftM NamedTarget $ get bh - _ -> liftM ModuleTarget $ get bh - -instance Outputable Annotation where - ppr ann = ppr (ann_target ann) - --- | A collection of annotations -data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) - , ann_name_env :: !(NameEnv [AnnPayload]) - } - --- | An empty annotation environment. -emptyAnnEnv :: AnnEnv -emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv - --- | Construct a new annotation environment that contains the list of --- annotations provided. -mkAnnEnv :: [Annotation] -> AnnEnv -mkAnnEnv = extendAnnEnvList emptyAnnEnv - --- | Add the given annotation to the environment. -extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv -extendAnnEnvList env = - foldl' extendAnnEnv env - -extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv -extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = - case tgt of - NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) - ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env - --- | Union two annotation environments. -plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv -plusAnnEnv a b = - MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) - , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) - } - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] -findAnns deserialize env - = mapMaybe (fromSerialized deserialize) . findAnnPayloads env - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] -findAnnsByTypeRep env target tyrep - = [ ws | Serialized tyrep' ws <- findAnnPayloads env target - , tyrep' == tyrep ] - --- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. -findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] -findAnnPayloads env target = - case target of - ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod - NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name - --- | Deserialize all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) -deserializeAnns deserialize env - = ( mapModuleEnv deserAnns (ann_mod_env env) - , mapNameEnv deserAnns (ann_name_env env) - ) - where deserAnns = mapMaybe (fromSerialized deserialize) - diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs --- a/compiler/main/Constants.hs +++ b/compiler/main/Constants.hs @@ -42,5 +42,9 @@ fLOAT_SIZE :: Int fLOAT_SIZE = 4 +-- Size of double in bytes. +dOUBLE_SIZE :: Int +dOUBLE_SIZE = 8 + tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -71,7 +71,7 @@ import Outputable import Panic import qualified PprColour as Col -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import FastString (unpackFS) import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) @@ -764,7 +764,7 @@ where whenPrintTimings = liftIO . when (prtimings == PrintTimings) eventBegins dflags w = do whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w) - liftIO $ traceEventIO (eventEndsDoc dflags w) + liftIO $ traceEventIO (eventBeginsDoc dflags w) eventEnds dflags w = do whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w) liftIO $ traceEventIO (eventEndsDoc dflags w) diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -4,7 +4,7 @@ import GhcPrelude import Outputable (SDoc, PprStyle ) -import SrcLoc (SrcSpan) +import GHC.Types.SrcLoc (SrcSpan) import Json import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -28,10 +28,10 @@ import Lexer import FastString import GHC.Hs -import Module +import GHC.Types.Module import PrelNames import StringBuffer -import SrcLoc +import GHC.Types.SrcLoc import GHC.Driver.Session import ErrUtils import Util @@ -40,7 +40,7 @@ import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception -import BasicTypes +import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/main/SysTools/Terminal.hs b/compiler/main/SysTools/Terminal.hs --- a/compiler/main/SysTools/Terminal.hs +++ b/compiler/main/SysTools/Terminal.hs @@ -32,20 +32,13 @@ stderrSupportsAnsiColors :: IO Bool stderrSupportsAnsiColors = do #if defined(MIN_VERSION_terminfo) - queryTerminal stdError `andM` do - (termSupportsColors <$> setupTermFromEnv) - `catch` \ (_ :: SetupTermError) -> - pure False - + stderr_available <- queryTerminal stdError + if stderr_available then + fmap termSupportsColors setupTermFromEnv + `catch` \ (_ :: SetupTermError) -> pure False + else + pure False where - - andM :: Monad m => m Bool -> m Bool -> m Bool - andM mx my = do - x <- mx - if x - then my - else pure x - termSupportsColors :: Terminal -> Bool termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 diff --git a/compiler/main/UnitInfo.hs b/compiler/main/UnitInfo.hs --- a/compiler/main/UnitInfo.hs +++ b/compiler/main/UnitInfo.hs @@ -37,8 +37,8 @@ import FastString import Outputable -import Module -import Unique +import GHC.Types.Module as Module +import GHC.Types.Unique -- ----------------------------------------------------------------------------- -- Our UnitInfo type is the InstalledPackageInfo from ghc-boot, @@ -58,7 +58,10 @@ -- other compact string types, e.g. plain ByteString or Text. newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) -newtype PackageName = PackageName FastString deriving (Eq, Ord) +newtype PackageName = PackageName + { unPackageName :: FastString + } + deriving (Eq, Ord) instance BinaryStringRep SourcePackageId where fromStringRep = SourcePackageId . mkFastStringByteString diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -15,9 +15,9 @@ import GhcPrelude -import RdrName +import GHC.Types.Name.Reader import Outputable -import SrcLoc +import GHC.Types.SrcLoc import qualified Data.Map as Map import Data.Data diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -5,7 +5,7 @@ import GhcPrelude import GHC.Hs -import SrcLoc +import GHC.Types.SrcLoc import Control.Monad diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -104,24 +104,24 @@ import GhcPrelude import GHC.Hs -- Lots of it -import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import DataCon ( DataCon, dataConTyCon ) -import ConLike ( ConLike(..) ) -import CoAxiom ( Role, fsFromRole ) -import RdrName -import Name -import BasicTypes +import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) +import GHC.Core.DataCon ( DataCon, dataConTyCon ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Basic import Lexer -import Lexeme ( isLexCon ) -import Type ( TyThing(..), funTyCon ) +import GHC.Utils.Lexeme ( isLexCon ) +import GHC.Core.Type ( TyThing(..), funTyCon ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, tupleTyConName, cTupleTyConNameArity_maybe ) -import ForeignCall +import GHC.Types.ForeignCall import PrelNames ( allNameStrings ) -import SrcLoc -import Unique ( hasKey ) +import GHC.Types.SrcLoc +import GHC.Types.Unique ( hasKey ) import OrdList ( OrdList, fromOL ) import Bag ( emptyBag, consBag ) import Outputable @@ -2548,7 +2548,7 @@ -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) mkInlinePragma src (inl, match_info) mb_act - = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes + = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.Basic , inl_inline = inl , inl_sat = Nothing , inl_act = act diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs deleted file mode 100644 --- a/compiler/prelude/ForeignCall.hs +++ /dev/null @@ -1,348 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Foreign]{Foreign calls} --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module ForeignCall ( - ForeignCall(..), isSafeForeignCall, - Safety(..), playSafe, playInterruptible, - - CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, - CCallSpec(..), - CCallTarget(..), isDynamicTarget, - CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - - Header(..), CType(..), - ) where - -import GhcPrelude - -import FastString -import Binary -import Outputable -import Module -import BasicTypes ( SourceText, pprWithSourceText ) - -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsubsection{Data types} -* * -************************************************************************ --} - -newtype ForeignCall = CCall CCallSpec - deriving Eq - -isSafeForeignCall :: ForeignCall -> Bool -isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe - --- We may need more clues to distinguish foreign calls --- but this simple printer will do for now -instance Outputable ForeignCall where - ppr (CCall cc) = ppr cc - -data Safety - = PlaySafe -- Might invoke Haskell GC, or do a call back, or - -- switch threads, etc. So make sure things are - -- tidy before the call. Additionally, in the threaded - -- RTS we arrange for the external call to be executed - -- by a separate OS thread, i.e., _concurrently_ to the - -- execution of other Haskell threads. - - | PlayInterruptible -- Like PlaySafe, but additionally - -- the worker thread running this foreign call may - -- be unceremoniously killed, so it must be scheduled - -- on an unbound thread. - - | PlayRisky -- None of the above can happen; the call will return - -- without interacting with the runtime system at all - deriving ( Eq, Show, Data ) - -- Show used just for Show Lex.Token, I think - -instance Outputable Safety where - ppr PlaySafe = text "safe" - ppr PlayInterruptible = text "interruptible" - ppr PlayRisky = text "unsafe" - -playSafe :: Safety -> Bool -playSafe PlaySafe = True -playSafe PlayInterruptible = True -playSafe PlayRisky = False - -playInterruptible :: Safety -> Bool -playInterruptible PlayInterruptible = True -playInterruptible _ = False - -{- -************************************************************************ -* * -\subsubsection{Calling C} -* * -************************************************************************ --} - -data CExportSpec - = CExportStatic -- foreign export ccall foo :: ty - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C Name of exported function - CCallConv - deriving Data - -data CCallSpec - = CCallSpec CCallTarget -- What to call - CCallConv -- Calling convention to use. - Safety - deriving( Eq ) - --- The call target: - --- | How to call a particular function in C-land. -data CCallTarget - -- An "unboxed" ccall# to named function in a particular package. - = StaticTarget - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C-land name of label. - - (Maybe UnitId) -- What package the function is in. - -- If Nothing, then it's taken to be in the current package. - -- Note: This information is only used for PrimCalls on Windows. - -- See CLabel.labelDynamic and CoreToStg.coreToStgApp - -- for the difference in representation between PrimCalls - -- and ForeignCalls. If the CCallTarget is representing - -- a regular ForeignCall then it's safe to set this to Nothing. - - -- The first argument of the import is the name of a function pointer (an Addr#). - -- Used when importing a label as "foreign import ccall "dynamic" ..." - Bool -- True => really a function - -- False => a value; only - -- allowed in CAPI imports - | DynamicTarget - - deriving( Eq, Data ) - -isDynamicTarget :: CCallTarget -> Bool -isDynamicTarget DynamicTarget = True -isDynamicTarget _ = False - -{- -Stuff to do with calling convention: - -ccall: Caller allocates parameters, *and* deallocates them. - -stdcall: Caller allocates parameters, callee deallocates. - Function name has @N after it, where N is number of arg bytes - e.g. _Foo@8. This convention is x86 (win32) specific. - -See: http://www.programmersheaven.com/2/Calling-conventions --} - --- any changes here should be replicated in the CallConv type in template haskell -data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Eq, Data) - -instance Outputable CCallConv where - ppr StdCallConv = text "stdcall" - ppr CCallConv = text "ccall" - ppr CApiConv = text "capi" - ppr PrimCallConv = text "prim" - ppr JavaScriptCallConv = text "javascript" - -defaultCCallConv :: CCallConv -defaultCCallConv = CCallConv - -ccallConvToInt :: CCallConv -> Int -ccallConvToInt StdCallConv = 0 -ccallConvToInt CCallConv = 1 -ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" -ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" -ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" - -{- -Generate the gcc attribute corresponding to the given -calling convention (used by PprAbsC): --} - -ccallConvAttribute :: CCallConv -> SDoc -ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" -ccallConvAttribute CCallConv = empty -ccallConvAttribute CApiConv = empty -ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" -ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" - -type CLabelString = FastString -- A C label, completely unencoded - -pprCLabelString :: CLabelString -> SDoc -pprCLabelString lbl = ftext lbl - -isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label -isCLabelString lbl - = all ok (unpackFS lbl) - where - ok c = isAlphaNum c || c == '_' || c == '.' - -- The '.' appears in e.g. "foo.so" in the - -- module part of a ExtName. Maybe it should be separate - --- Printing into C files: - -instance Outputable CExportSpec where - ppr (CExportStatic _ str _) = pprCLabelString str - -instance Outputable CCallSpec where - ppr (CCallSpec fun cconv safety) - = hcat [ whenPprDebug callconv, ppr_fun fun ] - where - callconv = text "{-" <> ppr cconv <> text "-}" - - gc_suf | playSafe safety = text "_GC" - | otherwise = empty - - ppr_fun (StaticTarget st _fn mPkgId isFun) - = text (if isFun then "__pkg_ccall" - else "__pkg_ccall_value") - <> gc_suf - <+> (case mPkgId of - Nothing -> empty - Just pkgId -> ppr pkgId) - <+> (pprWithSourceText st empty) - - ppr_fun DynamicTarget - = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - --- The filename for a C header file --- Note [Pragma source text] in BasicTypes -data Header = Header SourceText FastString - deriving (Eq, Data) - -instance Outputable Header where - ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) - --- | A C type, used in CAPI FFI calls --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, --- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', --- 'ApiAnnotation.AnnClose' @'\#-}'@, - --- For details on above see note [Api annotations] in ApiAnnotation -data CType = CType SourceText -- Note [Pragma source text] in BasicTypes - (Maybe Header) -- header to include for this type - (SourceText,FastString) -- the type itself - deriving (Eq, Data) - -instance Outputable CType where - ppr (CType stp mh (stct,ct)) - = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc - <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" - where hDoc = case mh of - Nothing -> empty - Just h -> ppr h - -{- -************************************************************************ -* * -\subsubsection{Misc} -* * -************************************************************************ --} - -instance Binary ForeignCall where - put_ bh (CCall aa) = put_ bh aa - get bh = do aa <- get bh; return (CCall aa) - -instance Binary Safety where - put_ bh PlaySafe = do - putByte bh 0 - put_ bh PlayInterruptible = do - putByte bh 1 - put_ bh PlayRisky = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return PlaySafe - 1 -> do return PlayInterruptible - _ -> do return PlayRisky - -instance Binary CExportSpec where - put_ bh (CExportStatic ss aa ab) = do - put_ bh ss - put_ bh aa - put_ bh ab - get bh = do - ss <- get bh - aa <- get bh - ab <- get bh - return (CExportStatic ss aa ab) - -instance Binary CCallSpec where - put_ bh (CCallSpec aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - aa <- get bh - ab <- get bh - ac <- get bh - return (CCallSpec aa ab ac) - -instance Binary CCallTarget where - put_ bh (StaticTarget ss aa ab ac) = do - putByte bh 0 - put_ bh ss - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh DynamicTarget = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do ss <- get bh - aa <- get bh - ab <- get bh - ac <- get bh - return (StaticTarget ss aa ab ac) - _ -> do return DynamicTarget - -instance Binary CCallConv where - put_ bh CCallConv = do - putByte bh 0 - put_ bh StdCallConv = do - putByte bh 1 - put_ bh PrimCallConv = do - putByte bh 2 - put_ bh CApiConv = do - putByte bh 3 - put_ bh JavaScriptCallConv = do - putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> do return CCallConv - 1 -> do return StdCallConv - 2 -> do return PrimCallConv - 3 -> do return CApiConv - _ -> do return JavaScriptCallConv - -instance Binary CType where - put_ bh (CType s mh fs) = do put_ bh s - put_ bh mh - put_ bh fs - get bh = do s <- get bh - mh <- get bh - fs <- get bh - return (CType s mh fs) - -instance Binary Header where - put_ bh (Header s h) = put_ bh s >> put_ bh h - get bh = do s <- get bh - h <- get bh - return (Header s h) diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs --- a/compiler/prelude/KnownUniques.hs +++ b/compiler/prelude/KnownUniques.hs @@ -29,13 +29,13 @@ import GhcPrelude import TysWiredIn -import TyCon -import DataCon -import Id -import BasicTypes +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Basic import Outputable -import Unique -import Name +import GHC.Types.Unique +import GHC.Types.Name import Util import Data.Bits @@ -65,7 +65,7 @@ -- tag (used to identify the sum's TypeRep binding). -- -- This layout is chosen to remain compatible with the usual unique allocation --- for wired-in data constructors described in Unique.hs +-- for wired-in data constructors described in GHC.Types.Unique -- -- TyCon for sum of arity k: -- 00000000 kkkkkkkk 11111100 diff --git a/compiler/prelude/KnownUniques.hs-boot b/compiler/prelude/KnownUniques.hs-boot --- a/compiler/prelude/KnownUniques.hs-boot +++ b/compiler/prelude/KnownUniques.hs-boot @@ -1,9 +1,9 @@ module KnownUniques where import GhcPrelude -import Unique -import Name -import BasicTypes +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.Basic -- Needed by TysWiredIn knownUniqueName :: Unique -> Maybe Name diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -139,7 +139,7 @@ When GHC reads the package data base, it (internally only) pretends it has UnitId `integer-wired-in` instead of the actual UnitId (which includes the version number); just like for `base` and other packages, as described in -Note [Wired-in packages] in Module. This is done in Packages.findWiredInPackages. +Note [Wired-in packages] in GHC.Types.Module. This is done in Packages.findWiredInPackages. -} {-# LANGUAGE CPP #-} @@ -160,12 +160,12 @@ import GhcPrelude -import Module -import OccName -import RdrName -import Unique -import Name -import SrcLoc +import GHC.Types.Module +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.SrcLoc import FastString {- @@ -803,9 +803,6 @@ showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") -undefined_RDR :: RdrName -undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") - error_RDR :: RdrName error_RDR = varQual_RDR gHC_ERR (fsLit "error") @@ -1592,17 +1589,8 @@ showClassKey = mkPreludeClassUnique 17 ixClassKey = mkPreludeClassUnique 18 -typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, - typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey - :: Unique +typeableClassKey :: Unique typeableClassKey = mkPreludeClassUnique 20 -typeable1ClassKey = mkPreludeClassUnique 21 -typeable2ClassKey = mkPreludeClassUnique 22 -typeable3ClassKey = mkPreludeClassUnique 23 -typeable4ClassKey = mkPreludeClassUnique 24 -typeable5ClassKey = mkPreludeClassUnique 25 -typeable6ClassKey = mkPreludeClassUnique 26 -typeable7ClassKey = mkPreludeClassUnique 27 monadFixClassKey :: Unique monadFixClassKey = mkPreludeClassUnique 28 @@ -1768,10 +1756,6 @@ tVarPrimTyConKey = mkPreludeTyConUnique 79 compactPrimTyConKey = mkPreludeTyConUnique 80 --- dotnet interop -objectTyConKey :: Unique -objectTyConKey = mkPreludeTyConUnique 83 - eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 @@ -2245,18 +2229,6 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 130 rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 - --- dotnet interop -unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, - unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique -unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 -marshalObjectIdKey = mkPreludeMiscIdUnique 151 -marshalStringIdKey = mkPreludeMiscIdUnique 152 -unmarshalStringIdKey = mkPreludeMiscIdUnique 153 -checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 - -undefinedKey :: Unique -undefinedKey = mkPreludeMiscIdUnique 155 magicDictKey :: Unique magicDictKey = mkPreludeMiscIdUnique 156 diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot --- a/compiler/prelude/PrelNames.hs-boot +++ b/compiler/prelude/PrelNames.hs-boot @@ -1,7 +1,7 @@ module PrelNames where -import Module -import Unique +import GHC.Types.Module +import GHC.Types.Unique mAIN :: Module liftedTypeKindTyConKey :: Unique diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs deleted file mode 100644 --- a/compiler/prelude/PrelRules.hs +++ /dev/null @@ -1,2256 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[ConFold]{Constant Folder} - -Conceptually, constant folding should be parameterized with the kind -of target machine to get identical behaviour during compilation time -and runtime. We cheat a little bit here... - -ToDo: - check boundaries before folding, e.g. we can fold the Float addition - (i1 + i2) only if it results in a valid Float. --} - -{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, - DeriveFunctor #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} - -module PrelRules - ( primOpRules - , builtinRules - , caseRules - ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) - -import GHC.Core -import GHC.Core.Make -import Id -import Literal -import GHC.Core.SimpleOpt ( exprIsLiteral_maybe ) -import PrimOp ( PrimOp(..), tagToEnumKey ) -import TysWiredIn -import TysPrim -import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon - , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons - , tyConFamilySize ) -import DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) -import GHC.Core.Utils ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType - , stripTicksTop, stripTicksTopT, mkTicks ) -import GHC.Core.Unfold ( exprIsConApp_maybe ) -import Type -import OccName ( occNameFS ) -import PrelNames -import Maybes ( orElse ) -import Name ( Name, nameOccName ) -import Outputable -import FastString -import BasicTypes -import GHC.Driver.Session -import GHC.Platform -import Util -import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) - -import Control.Applicative ( Alternative(..) ) - -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import Data.Bits as Bits -import qualified Data.ByteString as BS -import Data.Int -import Data.Ratio -import Data.Word - -{- -Note [Constant folding] -~~~~~~~~~~~~~~~~~~~~~~~ -primOpRules generates a rewrite rule for each primop -These rules do what is often called "constant folding" -E.g. the rules for +# might say - 4 +# 5 = 9 -Well, of course you'd need a lot of rules if you did it -like that, so we use a BuiltinRule instead, so that we -can match in any two literal values. So the rule is really -more like - (Lit x) +# (Lit y) = Lit (x+#y) -where the (+#) on the rhs is done at compile time - -That is why these rules are built in here. --} - -primOpRules :: Name -> PrimOp -> Maybe CoreRule - -- ToDo: something for integer-shift ops? - -- NotOp -primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] -primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] - --- Int operations -primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identityDynFlags zeroi - , numFoldingRules IntAddOp intPrimOps - ] -primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) - , rightIdentityDynFlags zeroi - , equalArgs >> retLit zeroi - , numFoldingRules IntSubOp intPrimOps - ] -primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) - , identityCDynFlags zeroi ] -primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) - , rightIdentityCDynFlags zeroi - , equalArgs >> retLitNoC zeroi ] -primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) - , zeroElem zeroi - , identityDynFlags onei - , numFoldingRules IntMulOp intPrimOps - ] -primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) - , leftZero zeroi - , rightIdentityDynFlags onei - , equalArgs >> retLit onei ] -primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) - , leftZero zeroi - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onei dflags) - retLit zeroi - , equalArgs >> retLit zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) - , idempotent - , zeroElem zeroi ] -primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) - , idempotent - , identityDynFlags zeroi ] -primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) - , identityDynFlags zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotIOp ] -primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp IntNegOp ] -primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical - , rightIdentityDynFlags zeroi ] - --- Word operations -primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identityDynFlags zerow - , numFoldingRules WordAddOp wordPrimOps - ] -primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) - , rightIdentityDynFlags zerow - , equalArgs >> retLit zerow - , numFoldingRules WordSubOp wordPrimOps - ] -primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) - , identityCDynFlags zerow ] -primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) - , rightIdentityCDynFlags zerow - , equalArgs >> retLitNoC zerow ] -primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) - , identityDynFlags onew - , numFoldingRules WordMulOp wordPrimOps - ] -primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentityDynFlags onew ] -primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) - , leftZero zerow - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onew dflags) - retLit zerow - , equalArgs >> retLit zerow ] -primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) - , idempotent - , zeroElem zerow ] -primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) - , idempotent - , identityDynFlags zerow ] -primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) - , identityDynFlags zerow - , equalArgs >> retLit zerow ] -primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotOp ] -primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] -primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] - --- coercions -primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit - , inversePrimOp Int2WordOp ] -primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit - , inversePrimOp Word2IntOp ] -primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit - , subsumedByPrimOp Narrow8IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp - , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] -primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp - , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] -primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , subsumedByPrimOp Narrow32IntOp - , removeOp32 - , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] -primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit - , subsumedByPrimOp Narrow8WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp - , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] -primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp - , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] -primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , subsumedByPrimOp Narrow32WordOp - , removeOp32 - , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] -primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit - , inversePrimOp ChrOp ] -primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs - guard (litFitsInChar lit) - liftLit int2CharLit - , inversePrimOp OrdOp ] -primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] -primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] -primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] -primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] --- SUP: Not sure what the standard says about precision in the following 2 cases -primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] -primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] - --- Float -primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) - , identity zerof ] -primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) - , rightIdentity zerof ] -primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) - , identity onef - , strengthReduction twof FloatAddOp ] - -- zeroElem zerof doesn't hold because of NaN -primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) - , rightIdentity onef ] -primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp FloatNegOp ] - --- Double -primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) - , identity zerod ] -primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) - , rightIdentity zerod ] -primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) - , identity oned - , strengthReduction twod DoubleAddOp ] - -- zeroElem zerod doesn't hold because of NaN -primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) - , rightIdentity oned ] -primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp DoubleNegOp ] - --- Relational operators - -primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] -primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] -primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] - -primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] -primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] - -primOpRules _ _ = Nothing - -{- -************************************************************************ -* * -\subsection{Doing the business} -* * -************************************************************************ --} - --- useful shorthands -mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) - -mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) - -> [RuleM CoreExpr] -> Maybe CoreRule -mkRelOpRule nm cmp extra - = mkPrimOpRule nm 2 $ - binaryCmpLit cmp : equal_rule : extra - where - -- x `cmp` x does not depend on x, so - -- compute it for the arbitrary value 'True' - -- and use that result - equal_rule = do { equalArgs - ; dflags <- getDynFlags - ; return (if cmp True True - then trueValInt dflags - else falseValInt dflags) } - -{- Note [Rules for floating-point comparisons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need different rules for floating-point values because for floats -it is not true that x = x (for NaNs); so we do not want the equal_rule -rule that mkRelOpRule uses. - -Note also that, in the case of equality/inequality, we do /not/ -want to switch to a case-expression. For example, we do not want -to convert - case (eqFloat# x 3.8#) of - True -> this - False -> that -to - case x of - 3.8#::Float# -> this - _ -> that -See #9238. Reason: comparing floating-point values for equality -delicate, and we don't want to implement that delicacy in the code for -case expressions. So we make it an invariant of Core that a case -expression never scrutinises a Float# or Double#. - -This transformation is what the litEq rule does; -see Note [The litEq rule: converting equality to case]. -So we /refrain/ from using litEq for mkFloatingRelOpRule. --} - -mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) - -> Maybe CoreRule --- See Note [Rules for floating-point comparisons] -mkFloatingRelOpRule nm cmp - = mkPrimOpRule nm 2 [binaryCmpLit cmp] - --- common constants -zeroi, onei, zerow, onew :: DynFlags -> Literal -zeroi dflags = mkLitInt dflags 0 -onei dflags = mkLitInt dflags 1 -zerow dflags = mkLitWord dflags 0 -onew dflags = mkLitWord dflags 1 - -zerof, onef, twof, zerod, oned, twod :: Literal -zerof = mkLitFloat 0.0 -onef = mkLitFloat 1.0 -twof = mkLitFloat 2.0 -zerod = mkLitDouble 0.0 -oned = mkLitDouble 1.0 -twod = mkLitDouble 2.0 - -cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) - -> Literal -> Literal -> Maybe CoreExpr -cmpOp dflags cmp = go - where - done True = Just $ trueValInt dflags - done False = Just $ falseValInt dflags - - -- These compares are at different types - go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) - go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) - go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) - go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) - | nt1 /= nt2 = Nothing - | otherwise = done (i1 `cmp` i2) - go _ _ = Nothing - --------------------------- - -negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate -negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f)) -negOp _ (LitDouble 0.0) = Nothing -negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d)) -negOp dflags (LitNumber nt i t) - | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) -negOp _ _ = Nothing - -complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement -complementOp dflags (LitNumber nt i t) = - Just (Lit (mkLitNumberWrap dflags nt (complement i) t)) -complementOp _ _ = Nothing - --------------------------- -intOp2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2 = intOp2' . const - -intOp2' :: (Integral a, Integral b) - => (DynFlags -> a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = - let o = op dflags - in intResult dflags (fromInteger i1 `o` fromInteger i2) -intOp2' _ _ _ _ = Nothing -- Could find LitLit - -intOpC2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do - intCResult dflags (fromInteger i1 `op` fromInteger i2) -intOpC2 _ _ _ _ = Nothing -- Could find LitLit - -shiftRightLogical :: DynFlags -> Integer -> Int -> Integer --- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do --- Do this by converting to Word and back. Obviously this won't work for big --- values, but its ok as we use it here -shiftRightLogical dflags x n = - case platformWordSize (targetPlatform dflags) of - PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) - PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) - --------------------------- -retLit :: (DynFlags -> Literal) -> RuleM CoreExpr -retLit l = do dflags <- getDynFlags - return $ Lit $ l dflags - -retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr -retLitNoC l = do dflags <- getDynFlags - let lit = l dflags - let ty = literalType lit - return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)] - -wordOp2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) - = wordResult dflags (fromInteger w1 `op` fromInteger w2) -wordOp2 _ _ _ _ = Nothing -- Could find LitLit - -wordOpC2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = - wordCResult dflags (fromInteger w1 `op` fromInteger w2) -wordOpC2 _ _ _ _ = Nothing -- Could find LitLit - -shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr --- Shifts take an Int; hence third arg of op is Int --- Used for shift primops --- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# --- SllOp, SrlOp :: Word# -> Int# -> Word# -shiftRule shift_op - = do { dflags <- getDynFlags - ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs - ; case e1 of - _ | shift_len == 0 - -> return e1 - -- See Note [Guarding against silly shifts] - | shift_len < 0 || shift_len > wordSizeInBits dflags - -> return $ Lit $ mkLitNumberWrap dflags LitNumInt 0 (exprType e1) - - -- Do the shift at type Integer, but shift length is Int - Lit (LitNumber nt x t) - | 0 < shift_len - , shift_len <= wordSizeInBits dflags - -> let op = shift_op dflags - y = x `op` fromInteger shift_len - in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) - - _ -> mzero } - -wordSizeInBits :: DynFlags -> Integer -wordSizeInBits dflags = toInteger (platformWordSizeInBits (targetPlatform dflags)) - --------------------------- -floatOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal - -> Maybe (Expr CoreBndr) -floatOp2 op dflags (LitFloat f1) (LitFloat f2) - = Just (mkFloatVal dflags (f1 `op` f2)) -floatOp2 _ _ _ _ = Nothing - --------------------------- -doubleOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal - -> Maybe (Expr CoreBndr) -doubleOp2 op dflags (LitDouble f1) (LitDouble f2) - = Just (mkDoubleVal dflags (f1 `op` f2)) -doubleOp2 _ _ _ _ = Nothing - --------------------------- -{- Note [The litEq rule: converting equality to case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This stuff turns - n ==# 3# -into - case n of - 3# -> True - m -> False - -This is a Good Thing, because it allows case-of case things -to happen, and case-default absorption to happen. For -example: - - if (n ==# 3#) || (n ==# 4#) then e1 else e2 -will transform to - case n of - 3# -> e1 - 4# -> e1 - m -> e2 -(modulo the usual precautions to avoid duplicating e1) --} - -litEq :: Bool -- True <=> equality, False <=> inequality - -> RuleM CoreExpr -litEq is_eq = msum - [ do [Lit lit, expr] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr - , do [expr, Lit lit] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr ] - where - do_lit_eq dflags lit expr = do - guard (not (litIsLifted lit)) - return (mkWildCase expr (literalType lit) intPrimTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) - where - val_if_eq | is_eq = trueValInt dflags - | otherwise = falseValInt dflags - val_if_neq | is_eq = falseValInt dflags - | otherwise = trueValInt dflags - - --- | Check if there is comparison with minBound or maxBound, that is --- always true or false. For instance, an Int cannot be smaller than its --- minBound, so we can replace such comparison with False. -boundsCmp :: Comparison -> RuleM CoreExpr -boundsCmp op = do - dflags <- getDynFlags - [a, b] <- getArgs - liftMaybe $ mkRuleFn dflags op a b - -data Comparison = Gt | Ge | Lt | Le - -mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn _ _ _ _ = Nothing - -isMinBound :: DynFlags -> Literal -> Bool -isMinBound _ (LitChar c) = c == minBound -isMinBound dflags (LitNumber nt i _) = case nt of - LitNumInt -> i == tARGET_MIN_INT dflags - LitNumInt64 -> i == toInteger (minBound :: Int64) - LitNumWord -> i == 0 - LitNumWord64 -> i == 0 - LitNumNatural -> i == 0 - LitNumInteger -> False -isMinBound _ _ = False - -isMaxBound :: DynFlags -> Literal -> Bool -isMaxBound _ (LitChar c) = c == maxBound -isMaxBound dflags (LitNumber nt i _) = case nt of - LitNumInt -> i == tARGET_MAX_INT dflags - LitNumInt64 -> i == toInteger (maxBound :: Int64) - LitNumWord -> i == tARGET_MAX_WORD dflags - LitNumWord64 -> i == toInteger (maxBound :: Word64) - LitNumNatural -> False - LitNumInteger -> False -isMaxBound _ _ = False - --- | Create an Int literal expression while ensuring the given Integer is in the --- target Int range -intResult :: DynFlags -> Integer -> Maybe CoreExpr -intResult dflags result = Just (intResult' dflags result) - -intResult' :: DynFlags -> Integer -> CoreExpr -intResult' dflags result = Lit (mkLitIntWrap dflags result) - --- | Create an unboxed pair of an Int literal expression, ensuring the given --- Integer is in the target Int range and the corresponding overflow flag --- (@0#@/@1#@) if it wasn't. -intCResult :: DynFlags -> Integer -> Maybe CoreExpr -intCResult dflags result = Just (mkPair [Lit lit, Lit c]) - where - mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] - (lit, b) = mkLitIntWrapC dflags result - c = if b then onei dflags else zeroi dflags - --- | Create a Word literal expression while ensuring the given Integer is in the --- target Word range -wordResult :: DynFlags -> Integer -> Maybe CoreExpr -wordResult dflags result = Just (wordResult' dflags result) - -wordResult' :: DynFlags -> Integer -> CoreExpr -wordResult' dflags result = Lit (mkLitWordWrap dflags result) - --- | Create an unboxed pair of a Word literal expression, ensuring the given --- Integer is in the target Word range and the corresponding carry flag --- (@0#@/@1#@) if it wasn't. -wordCResult :: DynFlags -> Integer -> Maybe CoreExpr -wordCResult dflags result = Just (mkPair [Lit lit, Lit c]) - where - mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] - (lit, b) = mkLitWordWrapC dflags result - c = if b then onei dflags else zeroi dflags - -inversePrimOp :: PrimOp -> RuleM CoreExpr -inversePrimOp primop = do - [Var primop_id `App` e] <- getArgs - matchPrimOpId primop primop_id - return e - -subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr -this `subsumesPrimOp` that = do - [Var primop_id `App` e] <- getArgs - matchPrimOpId that primop_id - return (Var (mkPrimOpId this) `App` e) - -subsumedByPrimOp :: PrimOp -> RuleM CoreExpr -subsumedByPrimOp primop = do - [e@(Var primop_id `App` _)] <- getArgs - matchPrimOpId primop primop_id - return e - --- | narrow subsumes bitwise `and` with full mask (cf #16402): --- --- narrowN (x .&. m) --- m .&. (2^N-1) = 2^N-1 --- ==> narrowN x --- --- e.g. narrow16 (x .&. 0xFFFF) --- ==> narrow16 x --- -narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr -narrowSubsumesAnd and_primop narrw n = do - [Var primop_id `App` x `App` y] <- getArgs - matchPrimOpId and_primop primop_id - let mask = bit n -1 - g v (Lit (LitNumber _ m _)) = do - guard (m .&. mask == mask) - return (Var (mkPrimOpId narrw) `App` v) - g _ _ = mzero - g x y <|> g y x - -idempotent :: RuleM CoreExpr -idempotent = do [e1, e2] <- getArgs - guard $ cheapEqExpr e1 e2 - return e1 - -{- -Note [Guarding against silly shifts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code: - - import Data.Bits( (.|.), shiftL ) - chunkToBitmap :: [Bool] -> Word32 - chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] - -This optimises to: -Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> - case w1_sCT of _ { - [] -> 0##; - : x_aAW xs_aAX -> - case x_aAW of _ { - GHC.Types.False -> - case w_sCS of wild2_Xh { - __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; - 9223372036854775807 -> 0## }; - GHC.Types.True -> - case GHC.Prim.>=# w_sCS 64 of _ { - GHC.Types.False -> - case w_sCS of wild3_Xh { - __DEFAULT -> - case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> - GHC.Prim.or# (GHC.Prim.narrow32Word# - (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) - ww_sCW - }; - 9223372036854775807 -> - GHC.Prim.narrow32Word# -!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) - }; - GHC.Types.True -> - case w_sCS of wild3_Xh { - __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; - 9223372036854775807 -> 0## - } } } } - -Note the massive shift on line "!!!!". It can't happen, because we've checked -that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! -Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we -can't constant fold it, but if it gets to the assembler we get - Error: operand type mismatch for `shl' - -So the best thing to do is to rewrite the shift with a call to error, -when the second arg is large. However, in general we cannot do this; consider -this case - - let x = I# (uncheckedIShiftL# n 80) - in ... - -Here x contains an invalid shift and consequently we would like to rewrite it -as follows: - - let x = I# (error "invalid shift) - in ... - -This was originally done in the fix to #16449 but this breaks the let/app -invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742. -For the reasons discussed in Note [Checking versus non-checking primops] (in -the PrimOp module) there is no safe way rewrite the argument of I# such that -it bottoms. - -Consequently we instead take advantage of the fact that large shifts are -undefined behavior (see associated documentation in primops.txt.pp) and -transform the invalid shift into an "obviously incorrect" value. - -There are two cases: - -- Shifting fixed-width things: the primops ISll, Sll, etc - These are handled by shiftRule. - - We are happy to shift by any amount up to wordSize but no more. - -- Shifting Integers: the function shiftLInteger, shiftRInteger - from the 'integer' library. These are handled by rule_shift_op, - and match_Integer_shift_op. - - Here we could in principle shift by any amount, but we arbitrary - limit the shift to 4 bits; in particular we do not want shift by a - huge amount, which can happen in code like that above. - -The two cases are more different in their code paths that is comfortable, -but that is only a historical accident. - - -************************************************************************ -* * -\subsection{Vaguely generic functions} -* * -************************************************************************ --} - -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule --- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = runRuleM rm } - -newtype RuleM r = RuleM - { runRuleM :: DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } - deriving (Functor) - -instance Applicative RuleM where - pure x = RuleM $ \_ _ _ _ -> Just x - (<*>) = ap - -instance Monad RuleM where - RuleM f >>= g - = RuleM $ \dflags iu fn args -> - case f dflags iu fn args of - Nothing -> Nothing - Just r -> runRuleM (g r) dflags iu fn args - -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - -instance MonadFail.MonadFail RuleM where - fail _ = mzero - -instance Alternative RuleM where - empty = RuleM $ \_ _ _ _ -> Nothing - RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu fn args -> - f1 dflags iu fn args <|> f2 dflags iu fn args - -instance MonadPlus RuleM - -instance HasDynFlags RuleM where - getDynFlags = RuleM $ \dflags _ _ _ -> Just dflags - -liftMaybe :: Maybe a -> RuleM a -liftMaybe Nothing = mzero -liftMaybe (Just x) = return x - -liftLit :: (Literal -> Literal) -> RuleM CoreExpr -liftLit f = liftLitDynFlags (const f) - -liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr -liftLitDynFlags f = do - dflags <- getDynFlags - [Lit lit] <- getArgs - return $ Lit (f dflags lit) - -removeOp32 :: RuleM CoreExpr -removeOp32 = do - dflags <- getDynFlags - case platformWordSize (targetPlatform dflags) of - PW4 -> do - [e] <- getArgs - return e - PW8 -> - mzero - -getArgs :: RuleM [CoreExpr] -getArgs = RuleM $ \_ _ _ args -> Just args - -getInScopeEnv :: RuleM InScopeEnv -getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu - -getFunction :: RuleM Id -getFunction = RuleM $ \_ _ fn _ -> Just fn - --- return the n-th argument of this rule, if it is a literal --- argument indices start from 0 -getLiteral :: Int -> RuleM Literal -getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of - (Lit l:_) -> Just l - _ -> Nothing - -unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr -unaryLit op = do - dflags <- getDynFlags - [Lit l] <- getArgs - liftMaybe $ op dflags (convFloating dflags l) - -binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr -binaryLit op = do - dflags <- getDynFlags - [Lit l1, Lit l2] <- getArgs - liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) - -binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr -binaryCmpLit op = do - dflags <- getDynFlags - binaryLit (\_ -> cmpOp dflags op) - -leftIdentity :: Literal -> RuleM CoreExpr -leftIdentity id_lit = leftIdentityDynFlags (const id_lit) - -rightIdentity :: Literal -> RuleM CoreExpr -rightIdentity id_lit = rightIdentityDynFlags (const id_lit) - -identity :: Literal -> RuleM CoreExpr -identity lit = leftIdentity lit `mplus` rightIdentity lit - -leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityDynFlags id_lit = do - dflags <- getDynFlags - [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags - return e2 - --- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in --- addition to the result, we have to indicate that no carry/overflow occurred. -leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityCDynFlags id_lit = do - dflags <- getDynFlags - [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags - let no_c = Lit (zeroi dflags) - return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) - -rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityDynFlags id_lit = do - dflags <- getDynFlags - [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags - return e1 - --- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in --- addition to the result, we have to indicate that no carry/overflow occurred. -rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityCDynFlags id_lit = do - dflags <- getDynFlags - [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags - let no_c = Lit (zeroi dflags) - return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) - -identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityDynFlags lit = - leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit - --- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition --- to the result, we have to indicate that no carry/overflow occurred. -identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityCDynFlags lit = - leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit - -leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr -leftZero zero = do - dflags <- getDynFlags - [Lit l1, _] <- getArgs - guard $ l1 == zero dflags - return $ Lit l1 - -rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr -rightZero zero = do - dflags <- getDynFlags - [_, Lit l2] <- getArgs - guard $ l2 == zero dflags - return $ Lit l2 - -zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr -zeroElem lit = leftZero lit `mplus` rightZero lit - -equalArgs :: RuleM () -equalArgs = do - [e1, e2] <- getArgs - guard $ e1 `cheapEqExpr` e2 - -nonZeroLit :: Int -> RuleM () -nonZeroLit n = getLiteral n >>= guard . not . isZeroLit - --- When excess precision is not requested, cut down the precision of the --- Rational value to that of Float/Double. We confuse host architecture --- and target architecture here, but it's convenient (and wrong :-). -convFloating :: DynFlags -> Literal -> Literal -convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) = - LitFloat (toRational (fromRational f :: Float )) -convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) = - LitDouble (toRational (fromRational d :: Double)) -convFloating _ l = l - -guardFloatDiv :: RuleM () -guardFloatDiv = do - [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs - guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] - && f2 /= 0 -- avoid NaN and Infinity/-Infinity - -guardDoubleDiv :: RuleM () -guardDoubleDiv = do - [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs - guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] - && d2 /= 0 -- avoid NaN and Infinity/-Infinity --- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to --- zero, but we might want to preserve the negative zero here which --- is representable in Float/Double but not in (normalised) --- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? - -strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr -strengthReduction two_lit add_op = do -- Note [Strength reduction] - arg <- msum [ do [arg, Lit mult_lit] <- getArgs - guard (mult_lit == two_lit) - return arg - , do [Lit mult_lit, arg] <- getArgs - guard (mult_lit == two_lit) - return arg ] - return $ Var (mkPrimOpId add_op) `App` arg `App` arg - --- Note [Strength reduction] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This rule turns floating point multiplications of the form 2.0 * x and --- x * 2.0 into x + x addition, because addition costs less than multiplication. --- See #7116 - --- Note [What's true and false] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- trueValInt and falseValInt represent true and false values returned by --- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. --- True is represented as an unboxed 1# literal, while false is represented --- as 0# literal. --- We still need Bool data constructors (True and False) to use in a rule --- for constant folding of equal Strings - -trueValInt, falseValInt :: DynFlags -> Expr CoreBndr -trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] -falseValInt dflags = Lit $ zeroi dflags - -trueValBool, falseValBool :: Expr CoreBndr -trueValBool = Var trueDataConId -- see Note [What's true and false] -falseValBool = Var falseDataConId - -ltVal, eqVal, gtVal :: Expr CoreBndr -ltVal = Var ordLTDataConId -eqVal = Var ordEQDataConId -gtVal = Var ordGTDataConId - -mkIntVal :: DynFlags -> Integer -> Expr CoreBndr -mkIntVal dflags i = Lit (mkLitInt dflags i) -mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr -mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f)) -mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr -mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d)) - -matchPrimOpId :: PrimOp -> Id -> RuleM () -matchPrimOpId op id = do - op' <- liftMaybe $ isPrimOpId_maybe id - guard $ op == op' - -{- -************************************************************************ -* * -\subsection{Special rules for seq, tagToEnum, dataToTag} -* * -************************************************************************ - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude but it works. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -We used to make this check in the type inference engine, but it's quite -ugly to do so, because the delayed constraint solving means that we don't -really know what's going on until the end. It's very much a corner case -because we don't expect the user to call tagToEnum# at all; we merely -generate calls in derived instances of Enum. So we compromise: a -rewrite rule rewrites a bad instance of tagToEnum# to an error call, -and emits a warning. --} - -tagToEnumRule :: RuleM CoreExpr --- If data T a = A | B | C --- then tag2Enum# (T ty) 2# --> B ty -tagToEnumRule = do - [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs - case splitTyConApp_maybe ty of - Just (tycon, tc_args) | isEnumerationTyCon tycon -> do - let tag = fromInteger i - correct_tag dc = (dataConTagZ dc) == tag - (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - ASSERT(null rest) return () - return $ mkTyApps (Var (dataConWorkId dc)) tc_args - - -- See Note [tagToEnum#] - _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) - return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" - ------------------------------- -dataToTagRule :: RuleM CoreExpr --- See Note [dataToTag#] in primops.txt.pp -dataToTagRule = a `mplus` b - where - -- dataToTag (tagToEnum x) ==> x - a = do - [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs - guard $ tag_to_enum `hasKey` tagToEnumKey - guard $ ty1 `eqType` ty2 - return tag - - -- dataToTag (K e1 e2) ==> tag-of K - -- This also works (via exprIsConApp_maybe) for - -- dataToTag x - -- where x's unfolding is a constructor application - b = do - dflags <- getDynFlags - [_, val_arg] <- getArgs - in_scope <- getInScopeEnv - (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg - ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () - return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) - -{- Note [dataToTag# magic] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The primop dataToTag# is unusual because it evaluates its argument. -Only `SeqOp` shares that property. (Other primops do not do anything -as fancy as argument evaluation.) The special handling for dataToTag# -is: - -* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp, - (actually in app_ok). Most primops with lifted arguments do not - evaluate those arguments, but DataToTagOp and SeqOp are two - exceptions. We say that they are /never/ ok-for-speculation, - regardless of the evaluated-ness of their argument. - See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp] - -* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr, - that evaluates its argument and then extracts the tag from - the returned value. - -* An application like (dataToTag# (Just x)) is optimised by - dataToTagRule in PrelRules. - -* A case expression like - case (dataToTag# e) of - gets transformed t - case e of - by PrelRules.caseRules; see Note [caseRules for dataToTag] - -See #15696 for a long saga. --} - -{- ********************************************************************* -* * - unsafeEqualityProof -* * -********************************************************************* -} - --- unsafeEqualityProof k t t ==> UnsafeRefl (Refl t) --- That is, if the two types are equal, it's not unsafe! - -unsafeEqualityProofRule :: RuleM CoreExpr -unsafeEqualityProofRule - = do { [Type rep, Type t1, Type t2] <- getArgs - ; guard (t1 `eqType` t2) - ; fn <- getFunction - ; let (_, ue) = splitForAllTys (idType fn) - tc = tyConAppTyCon ue -- tycon: UnsafeEquality - (dc:_) = tyConDataCons tc -- data con: UnsafeRefl - -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r). - -- UnsafeEquality r a a - ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) } - - -{- ********************************************************************* -* * - Rules for seq# and spark# -* * -********************************************************************* -} - -{- Note [seq# magic] -~~~~~~~~~~~~~~~~~~~~ -The primop - seq# :: forall a s . a -> State# s -> (# State# s, a #) - -is /not/ the same as the Prelude function seq :: a -> b -> b -as you can see from its type. In fact, seq# is the implementation -mechanism for 'evaluate' - - evaluate :: a -> IO a - evaluate a = IO $ \s -> seq# a s - -The semantics of seq# is - * evaluate its first argument - * and return it - -Things to note - -* Why do we need a primop at all? That is, instead of - case seq# x s of (# x, s #) -> blah - why not instead say this? - case x of { DEFAULT -> blah) - - Reason (see #5129): if we saw - catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler - - then we'd drop the 'case x' because the body of the case is bottom - anyway. But we don't want to do that; the whole /point/ of - seq#/evaluate is to evaluate 'x' first in the IO monad. - - In short, we /always/ evaluate the first argument and never - just discard it. - -* Why return the value? So that we can control sharing of seq'd - values: in - let x = e in x `seq` ... x ... - We don't want to inline x, so better to represent it as - let x = e in case seq# x RW of (# _, x' #) -> ... x' ... - also it matches the type of rseq in the Eval monad. - -Implementing seq#. The compiler has magic for SeqOp in - -- PrelRules.seqRule: eliminate (seq# s) - -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - -- GHC.Core.Utils.exprOkForSpeculation; - see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils - -- Simplify.addEvals records evaluated-ness for the result; see - Note [Adding evaluatedness info to pattern-bound variables] - in Simplify --} - -seqRule :: RuleM CoreExpr -seqRule = do - [Type ty_a, Type _ty_s, a, s] <- getArgs - guard $ exprIsHNF a - return $ mkCoreUbxTup [exprType s, ty_a] [s, a] - --- spark# :: forall a s . a -> State# s -> (# State# s, a #) -sparkRule :: RuleM CoreExpr -sparkRule = seqRule -- reduce on HNF, just the same - -- XXX perhaps we shouldn't do this, because a spark eliminated by - -- this rule won't be counted as a dud at runtime? - -{- -************************************************************************ -* * -\subsection{Built in rules} -* * -************************************************************************ - -Note [Scoping for Builtin rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When compiling a (base-package) module that defines one of the -functions mentioned in the RHS of a built-in rule, there's a danger -that we'll see - - f = ...(eq String x).... - - ....and lower down... - - eqString = ... - -Then a rewrite would give - - f = ...(eqString x)... - ....and lower down... - eqString = ... - -and lo, eqString is not in scope. This only really matters when we -get to code generation. But the occurrence analyser does a GlomBinds -step when necessary, that does a new SCC analysis on the whole set of -bindings (see occurAnalysePgm), which sorts out the dependency, so all -is fine. --} - -builtinRules :: [CoreRule] --- Rules for non-primops that can't be expressed using a RULE pragma -builtinRules - = [BuiltinRule { ru_name = fsLit "AppendLitString", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, - ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, - - mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, - - mkBasicRule divIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 div) - , leftZero zeroi - , do - [arg, Lit (LitNumber LitNumInt d _)] <- getArgs - Just n <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n - ], - - mkBasicRule modIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 mod) - , leftZero zeroi - , do - [arg, Lit (LitNumber LitNumInt d _)] <- getArgs - Just _ <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId AndIOp) - `App` arg `App` mkIntVal dflags (d - 1) - ] - ] - ++ builtinIntegerRules - ++ builtinNaturalRules -{-# NOINLINE builtinRules #-} --- there is no benefit to inlining these yet, despite this, GHC produces --- unfoldings for this regardless since the floated list entries look small. - -builtinIntegerRules :: [CoreRule] -builtinIntegerRules = - [rule_IntToInteger "smallInteger" smallIntegerName, - rule_WordToInteger "wordToInteger" wordToIntegerName, - rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, - rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, - rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), - rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), - rule_binop "plusInteger" plusIntegerName (+), - rule_binop "minusInteger" minusIntegerName (-), - rule_binop "timesInteger" timesIntegerName (*), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), - rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Prim "leInteger#" leIntegerPrimName (<=), - rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), - rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), - rule_binop_Prim "geInteger#" geIntegerPrimName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, - rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), - rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, - rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, - rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), - rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, - rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_shift_op "shiftLInteger" shiftLIntegerName shiftL, - rule_shift_op "shiftRInteger" shiftRIntegerName shiftR, - rule_bitInteger "bitInteger" bitIntegerName, - -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs - rule_divop_one "quotInteger" quotIntegerName quot, - rule_divop_one "remInteger" remIntegerName rem, - rule_divop_one "divInteger" divIntegerName div, - rule_divop_one "modInteger" modIntegerName mod, - rule_divop_both "divModInteger" divModIntegerName divMod, - rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, - -- These rules below don't actually have to be built in, but if we - -- put them in the Haskell source then we'd have to duplicate them - -- between all Integer implementations - rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, - rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, - rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, - rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, - rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, - rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, - rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp - ] - where rule_convert str name convert - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_convert convert } - rule_IntToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger } - rule_WordToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToInteger } - rule_Int64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Int64ToInteger } - rule_Word64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Word64ToInteger } - rule_unop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_unop op } - rule_bitInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_bitInteger } - rule_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop op } - rule_divop_both str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_both op } - rule_divop_one str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_one op } - rule_shift_op str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_shift_op op } - rule_binop_Prim str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Prim op } - rule_binop_Ordering str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Ordering op } - rule_encodeFloat str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_Int_encodeFloat op } - rule_decodeDouble str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_decodeDouble } - rule_XToIntegerToX str name toIntegerName - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_XToIntegerToX toIntegerName } - rule_smallIntegerTo str name primOp - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_smallIntegerTo primOp } - rule_rationalTo str name mkLit - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_rationalTo mkLit } - -builtinNaturalRules :: [CoreRule] -builtinNaturalRules = - [rule_binop "plusNatural" plusNaturalName (+) - ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing) - ,rule_binop "timesNatural" timesNaturalName (*) - ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName - ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName - ,rule_WordToNatural "wordToNatural" wordToNaturalName - ] - where rule_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Natural_binop op } - rule_partial_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Natural_partial_binop op } - rule_NaturalToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_NaturalToInteger } - rule_NaturalFromInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_NaturalFromInteger } - rule_WordToNatural str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToNatural } - ---------------------------------------------------- --- The rule is this: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) --- = unpackFoldrCString# "foobaz" c n - -match_append_lit :: RuleFun -match_append_lit _ id_unf _ - [ Type ty1 - , lit1 - , c1 - , e2 - ] - -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the - -- `lit` and `c` arguments, lest this may fail to fire when building with - -- -g3. See #16740. - | (strTicks, Var unpk `App` Type ty2 - `App` lit2 - `App` c2 - `App` n) <- stripTicksTop tickishFloatable e2 - , unpk `hasKey` unpackCStringFoldrIdKey - , cheapEqExpr' tickishFloatable c1 c2 - , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 - , c2Ticks <- stripTicksTopT tickishFloatable c2 - , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 - = ASSERT( ty1 `eqType` ty2 ) - Just $ mkTicks strTicks - $ Var unpk `App` Type ty1 - `App` Lit (LitString (s1 `BS.append` s2)) - `App` mkTicks (c1Ticks ++ c2Ticks) c1' - `App` n - -match_append_lit _ _ _ _ = Nothing - ---------------------------------------------------- --- The rule is this: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 - -match_eq_string :: RuleFun -match_eq_string _ id_unf _ - [Var unpk1 `App` lit1, Var unpk2 `App` lit2] - | unpk1 `hasKey` unpackCStringIdKey - , unpk2 `hasKey` unpackCStringIdKey - , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 - = Just (if s1 == s2 then trueValBool else falseValBool) - -match_eq_string _ _ _ _ = Nothing - - ---------------------------------------------------- --- The rule is this: --- inline f_ty (f a b c) = a b c --- (if f has an unfolding, EVEN if it's a loop breaker) --- --- It's important to allow the argument to 'inline' to have args itself --- (a) because its more forgiving to allow the programmer to write --- inline f a b c --- or inline (f a b c) --- (b) because a polymorphic f wll get a type argument that the --- programmer can't avoid --- --- Also, don't forget about 'inline's type argument! -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) - | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! - = Just (mkApps unf args1) - -match_inline _ = Nothing - - --- See Note [magicDictId magic] in `basicTypes/MkId.hs` --- for a description of what is going on here. -match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] - | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap - , Just (dictTy, _) <- splitFunTy_maybe fieldTy - , Just dictTc <- tyConAppTyCon_maybe dictTy - , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc - = Just - $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) - `App` y - -match_magicDict _ = Nothing - -------------------------------------------------- --- Integer rules --- smallInteger (79::Int#) = 79::Integer --- wordToInteger (79::Word#) = 79::Integer --- Similarly Int64, Word64 - -match_IntToInteger :: RuleFun -match_IntToInteger = match_IntToInteger_unop id - -match_WordToInteger :: RuleFun -match_WordToInteger _ id_unf id [xl] - | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_WordToInteger: Id has the wrong type" -match_WordToInteger _ _ _ _ = Nothing - -match_Int64ToInteger :: RuleFun -match_Int64ToInteger _ id_unf id [xl] - | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_Int64ToInteger: Id has the wrong type" -match_Int64ToInteger _ _ _ _ = Nothing - -match_Word64ToInteger :: RuleFun -match_Word64ToInteger _ id_unf id [xl] - | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_Word64ToInteger: Id has the wrong type" -match_Word64ToInteger _ _ _ _ = Nothing - -match_NaturalToInteger :: RuleFun -match_NaturalToInteger _ id_unf id [xl] - | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> - Just (Lit (LitNumber LitNumInteger x naturalTy)) - _ -> - panic "match_NaturalToInteger: Id has the wrong type" -match_NaturalToInteger _ _ _ _ = Nothing - -match_NaturalFromInteger :: RuleFun -match_NaturalFromInteger _ id_unf id [xl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , x >= 0 - = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> - Just (Lit (LitNumber LitNumNatural x naturalTy)) - _ -> - panic "match_NaturalFromInteger: Id has the wrong type" -match_NaturalFromInteger _ _ _ _ = Nothing - -match_WordToNatural :: RuleFun -match_WordToNatural _ id_unf id [xl] - | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> - Just (Lit (LitNumber LitNumNatural x naturalTy)) - _ -> - panic "match_WordToNatural: Id has the wrong type" -match_WordToNatural _ _ _ _ = Nothing - -------------------------------------------------- -{- Note [Rewriting bitInteger] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For most types the bitInteger operation can be implemented in terms of shifts. -The integer-gmp package, however, can do substantially better than this if -allowed to provide its own implementation. However, in so doing it previously lost -constant-folding (see #8832). The bitInteger rule above provides constant folding -specifically for this function. - -There is, however, a bit of trickiness here when it comes to ranges. While the -AST encodes all integers as Integers, `bit` expects the bit -index to be given as an Int. Hence we coerce to an Int in the rule definition. -This will behave a bit funny for constants larger than the word size, but the user -should expect some funniness given that they will have at very least ignored a -warning in this case. --} - -match_bitInteger :: RuleFun --- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer -match_bitInteger dflags id_unf fn [arg] - | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg - , x >= 0 - , x <= (wordSizeInBits dflags - 1) - -- Make sure x is small enough to yield a decently small integer - -- Attempting to construct the Integer for - -- (bitInteger 9223372036854775807#) - -- would be a bad idea (#14959) - , let x_int = fromIntegral x :: Int - = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) - -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) - _ -> panic "match_IntToInteger_unop: Id has the wrong type" - -match_bitInteger _ _ _ _ = Nothing - - -------------------------------------------------- -match_Integer_convert :: Num a - => (DynFlags -> a -> Expr CoreBndr) - -> RuleFun -match_Integer_convert convert dflags id_unf _ [xl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert dflags (fromInteger x)) -match_Integer_convert _ _ _ _ _ = Nothing - -match_Integer_unop :: (Integer -> Integer) -> RuleFun -match_Integer_unop unop _ id_unf _ [xl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitNumber LitNumInteger (unop x) i)) -match_Integer_unop _ _ _ _ _ = Nothing - -match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun -match_IntToInteger_unop unop _ id_unf fn [xl] - | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) -> - Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) - _ -> - panic "match_IntToInteger_unop: Id has the wrong type" -match_IntToInteger_unop _ _ _ _ _ = Nothing - -match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitInteger (x `binop` y) i)) -match_Integer_binop _ _ _ _ _ = Nothing - -match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Natural_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitNatural (x `binop` y) i)) -match_Natural_binop _ _ _ _ _ = Nothing - -match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun -match_Natural_partial_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl - , Just z <- x `binop` y - = Just (Lit (mkLitNatural z i)) -match_Natural_partial_binop _ _ _ _ _ = Nothing - --- This helper is used for the quotRem and divMod functions -match_Integer_divop_both - :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun -match_Integer_divop_both divop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - , (r,s) <- x `divop` y - = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] -match_Integer_divop_both _ _ _ _ _ = Nothing - --- This helper is used for the quot and rem functions -match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_divop_one divop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (Lit (mkLitInteger (x `divop` y) i)) -match_Integer_divop_one _ _ _ _ _ = Nothing - -match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun --- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer --- See Note [Guarding against silly shifts] -match_Integer_shift_op binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl - , y >= 0 - , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat - -- arbitrary. We can get huge shifts in inaccessible code - -- (#15673) - = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i)) -match_Integer_shift_op _ _ _ _ _ = Nothing - -match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun -match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) -match_Integer_binop_Prim _ _ _ _ _ = Nothing - -match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun -match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just $ case x `binop` y of - LT -> ltVal - EQ -> eqVal - GT -> gtVal -match_Integer_binop_Ordering _ _ _ _ _ = Nothing - -match_Integer_Int_encodeFloat :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl - = Just (mkLit $ encodeFloat x (fromInteger y)) -match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing - ---------------------------------------------------- --- constant folding for Float/Double --- --- This turns --- rationalToFloat n d --- into a literal Float, and similarly for Doubles. --- --- it's important to not match d == 0, because that may represent a --- literal "0/0" or similar, and we can't produce a literal value for --- NaN or +-Inf -match_rationalTo :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_rationalTo mkLit _ id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (mkLit (fromRational (x % y))) -match_rationalTo _ _ _ _ _ = Nothing - -match_decodeDouble :: RuleFun -match_decodeDouble dflags id_unf fn [xl] - | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, res) - | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res - -> case decodeFloat (fromRational x :: Double) of - (y, z) -> - Just $ mkCoreUbxTup [integerTy, intHashTy] - [Lit (mkLitInteger y integerTy), - Lit (mkLitInt dflags (toInteger z))] - _ -> - pprPanic "match_decodeDouble: Id has the wrong type" - (ppr fn <+> dcolon <+> ppr (idType fn)) -match_decodeDouble _ _ _ _ = Nothing - -match_XToIntegerToX :: Name -> RuleFun -match_XToIntegerToX n _ _ _ [App (Var x) y] - | idName x == n - = Just y -match_XToIntegerToX _ _ _ _ _ = Nothing - -match_smallIntegerTo :: PrimOp -> RuleFun -match_smallIntegerTo primOp _ _ _ [App (Var x) y] - | idName x == smallIntegerName - = Just $ App (Var (mkPrimOpId primOp)) y -match_smallIntegerTo _ _ _ _ _ = Nothing - - - --------------------------------------------------------- --- Note [Constant folding through nested expressions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We use rewrites rules to perform constant folding. It means that we don't --- have a global view of the expression we are trying to optimise. As a --- consequence we only perform local (small-step) transformations that either: --- 1) reduce the number of operations --- 2) rearrange the expression to increase the odds that other rules will --- match --- --- We don't try to handle more complex expression optimisation cases that would --- require a global view. For example, rewriting expressions to increase --- sharing (e.g., Horner's method); optimisations that require local --- transformations increasing the number of operations; rearrangements to --- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). --- --- We already have rules to perform constant folding on expressions with the --- following shape (where a and/or b are literals): --- --- D) op --- /\ --- / \ --- / \ --- a b --- --- To support nested expressions, we match three other shapes of expression --- trees: --- --- A) op1 B) op1 C) op1 --- /\ /\ /\ --- / \ / \ / \ --- / \ / \ / \ --- a op2 op2 c op2 op3 --- /\ /\ /\ /\ --- / \ / \ / \ / \ --- b c a b a b c d --- --- --- R1) +/- simplification: --- ops = + or -, two literals (not siblings) --- --- Examples: --- A: 5 + (10-x) ==> 15-x --- B: (10+x) + 5 ==> 15+x --- C: (5+a)-(5-b) ==> 0+(a+b) --- --- R2) * simplification --- ops = *, two literals (not siblings) --- --- Examples: --- A: 5 * (10*x) ==> 50*x --- B: (10*x) * 5 ==> 50*x --- C: (5*a)*(5*b) ==> 25*(a*b) --- --- R3) * distribution over +/- --- op1 = *, op2 = + or -, two literals (not siblings) --- --- This transformation doesn't reduce the number of operations but switches --- the outer and the inner operations so that the outer is (+) or (-) instead --- of (*). It increases the odds that other rules will match after this one. --- --- Examples: --- A: 5 * (10-x) ==> 50 - (5*x) --- B: (10+x) * 5 ==> 50 + (5*x) --- C: Not supported as it would increase the number of operations: --- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b --- --- R4) Simple factorization --- --- op1 = + or -, op2/op3 = *, --- one literal for each innermost * operation (except in the D case), --- the two other terms are equals --- --- Examples: --- A: x - (10*x) ==> (-9)*x --- B: (10*x) + x ==> 11*x --- C: (5*x)-(x*3) ==> 2*x --- D: x+x ==> 2*x --- --- R5) +/- propagation --- --- ops = + or -, one literal --- --- This transformation doesn't reduce the number of operations but propagates --- the constant to the outer level. It increases the odds that other rules --- will match after this one. --- --- Examples: --- A: x - (10-y) ==> (x+y) - 10 --- B: (10+x) - y ==> 10 + (x-y) --- C: N/A (caught by the A and B cases) --- --------------------------------------------------------- - --- | Rules to perform constant folding into nested expressions --- ---See Note [Constant folding through nested expressions] -numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr -numFoldingRules op dict = do - [e1,e2] <- getArgs - dflags <- getDynFlags - let PrimOps{..} = dict dflags - if not (gopt Opt_NumConstantFolding dflags) - then mzero - else case BinOpApp e1 op e2 of - -- R1) +/- simplification - x :++: (y :++: v) -> return $ mkL (x+y) `add` v - x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v - x :++: (v :-: L y) -> return $ mkL (x-y) `add` v - L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v - L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v - L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v - - (y :++: v) :-: L x -> return $ mkL (y-x) `add` v - (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v - (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v - - (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) - (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) - (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v) - (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v) - (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w) - (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) - (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) - (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v) - (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w) - - (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w) - (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w) - (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w) - (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v) - (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) - (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) - (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) - (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) - (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) - - -- R2) * simplification - x :**: (y :**: v) -> return $ mkL (x*y) `mul` v - (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) - - -- R3) * distribution over +/- - x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v) - x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v) - x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y) - - -- R4) Simple factorization - v :+: w - | w `cheapEqExpr` v -> return $ mkL 2 `mul` v - w :+: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v - w :-: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v - (y :**: v) :+: w - | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v - (y :**: v) :-: w - | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v - (x :**: w) :+: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v - (x :**: w) :-: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v - - -- R5) +/- propagation - w :+: (y :++: v) -> return $ mkL y `add` (w `add` v) - (y :++: v) :+: w -> return $ mkL y `add` (w `add` v) - w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y - (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w) - w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y - (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v) - w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v) - w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y - (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v) - (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y - - _ -> mzero - - - --- | Match the application of a binary primop -pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr -pattern BinOpApp x op y = OpVal op `App` x `App` y - --- | Match a primop -pattern OpVal :: PrimOp -> Arg CoreBndr -pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where - OpVal op = Var (mkPrimOpId op) - - - --- | Match a literal -pattern L :: Integer -> Arg CoreBndr -pattern L l <- Lit (isLitValue_maybe -> Just l) - --- | Match an addition -pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr -pattern x :+: y <- BinOpApp x (isAddOp -> True) y - --- | Match an addition with a literal (handle commutativity) -pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr -pattern l :++: x <- (isAdd -> Just (l,x)) - -isAdd :: CoreExpr -> Maybe (Integer,CoreExpr) -isAdd e = case e of - L l :+: x -> Just (l,x) - x :+: L l -> Just (l,x) - _ -> Nothing - --- | Match a multiplication -pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr -pattern x :*: y <- BinOpApp x (isMulOp -> True) y - --- | Match a multiplication with a literal (handle commutativity) -pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr -pattern l :**: x <- (isMul -> Just (l,x)) - -isMul :: CoreExpr -> Maybe (Integer,CoreExpr) -isMul e = case e of - L l :*: x -> Just (l,x) - x :*: L l -> Just (l,x) - _ -> Nothing - - --- | Match a subtraction -pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr -pattern x :-: y <- BinOpApp x (isSubOp -> True) y - -isSubOp :: PrimOp -> Bool -isSubOp IntSubOp = True -isSubOp WordSubOp = True -isSubOp _ = False - -isAddOp :: PrimOp -> Bool -isAddOp IntAddOp = True -isAddOp WordAddOp = True -isAddOp _ = False - -isMulOp :: PrimOp -> Bool -isMulOp IntMulOp = True -isMulOp WordMulOp = True -isMulOp _ = False - --- | Explicit "type-class"-like dictionary for numeric primops --- --- Depends on DynFlags because creating a literal value depends on DynFlags -data PrimOps = PrimOps - { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers - , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers - , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers - , mkL :: Integer -> CoreExpr -- ^ Create a literal value - } - -intPrimOps :: DynFlags -> PrimOps -intPrimOps dflags = PrimOps - { add = \x y -> BinOpApp x IntAddOp y - , sub = \x y -> BinOpApp x IntSubOp y - , mul = \x y -> BinOpApp x IntMulOp y - , mkL = intResult' dflags - } - -wordPrimOps :: DynFlags -> PrimOps -wordPrimOps dflags = PrimOps - { add = \x y -> BinOpApp x WordAddOp y - , sub = \x y -> BinOpApp x WordSubOp y - , mul = \x y -> BinOpApp x WordMulOp y - , mkL = wordResult' dflags - } - - --------------------------------------------------------- --- Constant folding through case-expressions --- --- cf Scrutinee Constant Folding in simplCore/SimplUtils --------------------------------------------------------- - --- | Match the scrutinee of a case and potentially return a new scrutinee and a --- function to apply to each literal alternative. -caseRules :: DynFlags - -> CoreExpr -- Scrutinee - -> Maybe ( CoreExpr -- New scrutinee - , AltCon -> Maybe AltCon -- How to fix up the alt pattern - -- Nothing <=> Unreachable - -- See Note [Unreachable caseRules alternatives] - , Id -> CoreExpr) -- How to reconstruct the original scrutinee - -- from the new case-binder --- e.g case e of b { --- ...; --- con bs -> rhs; --- ... } --- ==> --- case e' of b' { --- ...; --- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; --- ... } - -caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# - | Just op <- isPrimOpId_maybe f - , Just x <- isLitValue_maybe l - , Just adjust_lit <- adjustDyadicRight op x - = Just (v, tx_lit_con dflags adjust_lit - , \v -> (App (App (Var f) (Var v)) (Lit l))) - -caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v - | Just op <- isPrimOpId_maybe f - , Just x <- isLitValue_maybe l - , Just adjust_lit <- adjustDyadicLeft x op - = Just (v, tx_lit_con dflags adjust_lit - , \v -> (App (App (Var f) (Lit l)) (Var v))) - - -caseRules dflags (App (Var f) v ) -- op v - | Just op <- isPrimOpId_maybe f - , Just adjust_lit <- adjustUnary op - = Just (v, tx_lit_con dflags adjust_lit - , \v -> App (Var f) (Var v)) - --- See Note [caseRules for tagToEnum] -caseRules dflags (App (App (Var f) type_arg) v) - | Just TagToEnumOp <- isPrimOpId_maybe f - = Just (v, tx_con_tte dflags - , \v -> (App (App (Var f) type_arg) (Var v))) - --- See Note [caseRules for dataToTag] -caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f - , Just (tc, _) <- tcSplitTyConApp_maybe ty - , isAlgTyCon tc - = Just (v, tx_con_dtt ty - , \v -> App (App (Var f) (Type ty)) (Var v)) - -caseRules _ _ = Nothing - - -tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon -tx_lit_con _ _ DEFAULT = Just DEFAULT -tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) -tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) - -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the - -- literal alternatives remain in Word/Int target ranges - -- (See Note [Word/Int underflow/overflow] in Literal and #13172). - -adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) --- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x -adjustDyadicRight op lit - = case op of - WordAddOp -> Just (\y -> y-lit ) - IntAddOp -> Just (\y -> y-lit ) - WordSubOp -> Just (\y -> y+lit ) - IntSubOp -> Just (\y -> y+lit ) - XorOp -> Just (\y -> y `xor` lit) - XorIOp -> Just (\y -> y `xor` lit) - _ -> Nothing - -adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) --- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x -adjustDyadicLeft lit op - = case op of - WordAddOp -> Just (\y -> y-lit ) - IntAddOp -> Just (\y -> y-lit ) - WordSubOp -> Just (\y -> lit-y ) - IntSubOp -> Just (\y -> lit-y ) - XorOp -> Just (\y -> y `xor` lit) - XorIOp -> Just (\y -> y `xor` lit) - _ -> Nothing - - -adjustUnary :: PrimOp -> Maybe (Integer -> Integer) --- Given (op x) return a function 'f' s.t. f (op x) = x -adjustUnary op - = case op of - NotOp -> Just (\y -> complement y) - NotIOp -> Just (\y -> complement y) - IntNegOp -> Just (\y -> negate y ) - _ -> Nothing - -tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon -tx_con_tte _ DEFAULT = Just DEFAULT -tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) -tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] - = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc - -tx_con_dtt :: Type -> AltCon -> Maybe AltCon -tx_con_dtt _ DEFAULT = Just DEFAULT -tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) - | tag >= 0 - , tag < n_data_cons - = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) - | otherwise - = Nothing - where - tag = fromInteger i :: ConTagZ - tc = tyConAppTyCon ty - n_data_cons = tyConFamilySize tc - data_cons = tyConDataCons tc - -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) - - -{- Note [caseRules for tagToEnum] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to transform - case tagToEnum x of - False -> e1 - True -> e2 -into - case x of - 0# -> e1 - 1# -> e2 - -This rule eliminates a lot of boilerplate. For - if (x>y) then e2 else e1 -we generate - case tagToEnum (x ># y) of - False -> e1 - True -> e2 -and it is nice to then get rid of the tagToEnum. - -Beware (#14768): avoid the temptation to map constructor 0 to -DEFAULT, in the hope of getting this - case (x ># y) of - DEFAULT -> e1 - 1# -> e2 -That fails utterly in the case of - data Colour = Red | Green | Blue - case tagToEnum x of - DEFAULT -> e1 - Red -> e2 - -We don't want to get this! - case x of - DEFAULT -> e1 - DEFAULT -> e2 - -Instead, we deal with turning one branch into DEFAULT in SimplUtils -(add_default in mkCase3). - -Note [caseRules for dataToTag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [dataToTag#] in primpops.txt.pp - -We want to transform - case dataToTag x of - DEFAULT -> e1 - 1# -> e2 -into - case x of - DEFAULT -> e1 - (:) _ _ -> e2 - -Note the need for some wildcard binders in -the 'cons' case. - -For the time, we only apply this transformation when the type of `x` is a type -headed by a normal tycon. In particular, we do not apply this in the case of a -data family tycon, since that would require carefully applying coercion(s) -between the data family and the data family instance's representation type, -which caseRules isn't currently engineered to handle (#14680). - -Note [Unreachable caseRules alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Take care if we see something like - case dataToTag x of - DEFAULT -> e1 - -1# -> e2 - 100 -> e3 -because there isn't a data constructor with tag -1 or 100. In this case the -out-of-range alternative is dead code -- we know the range of tags for x. - -Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating -an alternative that is unreachable. - -You may wonder how this can happen: check out #15436. --} diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -31,22 +31,22 @@ import TysWiredIn import GHC.Cmm.Type -import Demand -import Id ( Id, mkVanillaGlobalWithInfo ) -import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) -import Name -import PrelNames ( gHC_PRIMOPWRAPPERS ) -import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) -import Type -import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 ) -import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), - SourceText(..) ) -import SrcLoc ( wiredInSrcSpan ) -import ForeignCall ( CLabelString ) -import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) +import GHC.Types.Demand +import GHC.Types.Id ( Id, mkVanillaGlobalWithInfo ) +import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) +import GHC.Types.Name +import PrelNames ( gHC_PRIMOPWRAPPERS ) +import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) +import GHC.Core.Type +import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 ) +import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..), + SourceText(..) ) +import GHC.Types.SrcLoc ( wiredInSrcSpan ) +import GHC.Types.ForeignCall ( CLabelString ) +import GHC.Types.Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) +import GHC.Types.Module ( UnitId ) import Outputable import FastString -import Module ( UnitId ) {- ************************************************************************ @@ -498,7 +498,8 @@ {- Note [primOpIsCheap] ~~~~~~~~~~~~~~~~~~~~ -@primOpIsCheap@, as used in \tr{SimplUtils.hs}. For now (HACK + +@primOpIsCheap@, as used in GHC.Core.Op.Simplify.Utils. For now (HACK WARNING), we just borrow some other predicates for a what-should-be-good-enough test. "Cheap" means willing to call it more than once, and/or push it inside a lambda. The latter could change the diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -110,16 +110,16 @@ , doubleElemRepDataConTy , mkPromotedListTy ) -import Var ( TyVar, mkTyVar ) -import Name -import TyCon -import SrcLoc -import Unique +import GHC.Types.Var ( TyVar, mkTyVar ) +import GHC.Types.Name +import GHC.Core.TyCon +import GHC.Types.SrcLoc +import GHC.Types.Unique import PrelNames import FastString import Outputable -import TyCoRep -- Doesn't need special access, but this is easier to avoid - -- import loops which show up if you import Type instead +import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead import Data.Char @@ -475,14 +475,14 @@ Note [PrimRep and kindPrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As part of its source code, in TyCon, GHC has +As part of its source code, in GHC.Core.TyCon, GHC has data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... Notice that * RuntimeRep is part of the syntax tree of the program being compiled (defined in a library: ghc-prim:GHC.Types) * PrimRep is part of GHC's source code. - (defined in TyCon) + (defined in GHC.Core.TyCon) We need to get from one to the other; that is what kindPrimRep does. Suppose we have a value @@ -707,7 +707,7 @@ Type.classifyPredType. All wanted constraints of this type are built with coercion holes. -(See Note [Coercion holes] in TyCoRep.) But see also +(See Note [Coercion holes] in GHC.Core.TyCo.Rep.) But see also Note [Deferred errors for coercion holes] in TcErrors to see how equality constraints are deferred. diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -16,7 +16,7 @@ mkWiredInTyConName, -- This is used in TcTypeNats to define the -- built-in functions for evaluation. - mkWiredInIdName, -- used in MkId + mkWiredInIdName, -- used in GHC.Types.Id.Make -- * All wired in things wiredInTyCons, isBuiltInOcc_maybe, @@ -132,7 +132,7 @@ import GhcPrelude -import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) +import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) -- friends: import PrelNames @@ -140,24 +140,24 @@ import {-# SOURCE #-} KnownUniques -- others: -import CoAxiom -import Id +import GHC.Core.Coercion.Axiom +import GHC.Types.Id import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import Module ( Module ) -import Type +import GHC.Types.Module ( Module ) +import GHC.Core.Type import GHC.Types.RepType -import DataCon -import {-# SOURCE #-} ConLike -import TyCon -import Class ( Class, mkClass ) -import RdrName -import Name -import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes -import ForeignCall -import SrcLoc ( noSrcSpan ) -import Unique +import GHC.Core.DataCon +import {-# SOURCE #-} GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Class ( Class, mkClass ) +import GHC.Types.Name.Reader +import GHC.Types.Name as Name +import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) +import GHC.Types.Name.Set ( NameSet, mkNameSet, elemNameSet ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Types.Unique import Data.Array import FastString import Outputable @@ -933,7 +933,7 @@ tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con UnboxedTuple flavour - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) (\ks -> map tYPE ks) diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -1,10 +1,10 @@ module TysWiredIn where -import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep (Type, Kind) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind) -import BasicTypes (Arity, TupleSort) -import Name (Name) +import GHC.Types.Basic (Arity, TupleSort) +import GHC.Types.Name (Name) listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs deleted file mode 100644 --- a/compiler/profiling/CostCentre.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module CostCentre ( - CostCentre(..), CcName, CCFlavour(..), - -- All abstract except to friend: ParseIface.y - - CostCentreStack, - CollectedCCs, emptyCollectedCCs, collectCC, - currentCCS, dontCareCCS, - isCurrentCCS, - maybeSingletonCCS, - - mkUserCC, mkAutoCC, mkAllCafsCC, - mkSingletonCCS, - isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, - - pprCostCentreCore, - costCentreUserName, costCentreUserNameFS, - costCentreSrcSpan, - - cmpCostCentre -- used for removing dups in a list - ) where - -import GhcPrelude - -import Binary -import Var -import Name -import Module -import Unique -import Outputable -import SrcLoc -import FastString -import Util -import CostCentreState - -import Data.Data - ------------------------------------------------------------------------------ --- Cost Centres - --- | A Cost Centre is a single @{-# SCC #-}@ annotation. - -data CostCentre - = NormalCC { - cc_flavour :: CCFlavour, - -- ^ Two cost centres may have the same name and - -- module but different SrcSpans, so we need a way to - -- distinguish them easily and give them different - -- object-code labels. So every CostCentre has an - -- associated flavour that indicates how it was - -- generated, and flavours that allow multiple instances - -- of the same name and module have a deterministic 0-based - -- index. - cc_name :: CcName, -- ^ Name of the cost centre itself - cc_mod :: Module, -- ^ Name of module defining this CC. - cc_loc :: SrcSpan - } - - | AllCafsCC { - cc_mod :: Module, -- Name of module defining this CC. - cc_loc :: SrcSpan - } - deriving Data - -type CcName = FastString - --- | The flavour of a cost centre. --- --- Index fields represent 0-based indices giving source-code ordering of --- centres with the same module, name, and flavour. -data CCFlavour = CafCC -- ^ Auto-generated top-level thunk - | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression - | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration - | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage - deriving (Eq, Ord, Data) - --- | Extract the index from a flavour -flavourIndex :: CCFlavour -> Int -flavourIndex CafCC = 0 -flavourIndex (ExprCC x) = unCostCentreIndex x -flavourIndex (DeclCC x) = unCostCentreIndex x -flavourIndex (HpcCC x) = unCostCentreIndex x - -instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } - -instance Ord CostCentre where - compare = cmpCostCentre - -cmpCostCentre :: CostCentre -> CostCentre -> Ordering - -cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) - = m1 `compare` m2 - -cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} - NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} - -- first key is module name, then centre name, then flavour - = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) - -cmpCostCentre other_1 other_2 - = let - tag1 = tag_CC other_1 - tag2 = tag_CC other_2 - in - if tag1 < tag2 then LT else GT - where - tag_CC :: CostCentre -> Int - tag_CC (NormalCC {}) = 0 - tag_CC (AllCafsCC {}) = 1 - - ------------------------------------------------------------------------------ --- Predicates on CostCentre - -isCafCC :: CostCentre -> Bool -isCafCC (AllCafsCC {}) = True -isCafCC (NormalCC {cc_flavour = CafCC}) = True -isCafCC _ = False - --- | Is this a cost-centre which records scc counts -isSccCountCC :: CostCentre -> Bool -isSccCountCC cc | isCafCC cc = False - | otherwise = True - --- | Is this a cost-centre which can be sccd ? -sccAbleCC :: CostCentre -> Bool -sccAbleCC cc | isCafCC cc = False - | otherwise = True - -ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == m - - ------------------------------------------------------------------------------ --- Building cost centres - -mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre -mkUserCC cc_name mod loc flavour - = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, - cc_flavour = flavour - } - -mkAutoCC :: Id -> Module -> CostCentre -mkAutoCC id mod - = NormalCC { cc_name = str, cc_mod = mod, - cc_loc = nameSrcSpan (getName id), - cc_flavour = CafCC - } - where - name = getName id - -- beware: only external names are guaranteed to have unique - -- Occnames. If the name is not external, we must append its - -- Unique. - -- See bug #249, tests prof001, prof002, also #2411 - str | isExternalName name = occNameFS (getOccName id) - | otherwise = occNameFS (getOccName id) - `appendFS` - mkFastString ('_' : show (getUnique name)) -mkAllCafsCC :: Module -> SrcSpan -> CostCentre -mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } - ------------------------------------------------------------------------------ --- Cost Centre Stacks - --- | A Cost Centre Stack is something that can be attached to a closure. --- This is either: --- --- * the current cost centre stack (CCCS) --- * a pre-defined cost centre stack (there are several --- pre-defined CCSs, see below). - -data CostCentreStack - = CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. - - | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. - - | SingletonCCS CostCentre - - deriving (Eq, Ord) -- needed for Ord on CLabel - - --- synonym for triple which describes the cost centre info in the generated --- code for a module. -type CollectedCCs - = ( [CostCentre] -- local cost-centres that need to be decl'd - , [CostCentreStack] -- pre-defined "singleton" cost centre stacks - ) - -emptyCollectedCCs :: CollectedCCs -emptyCollectedCCs = ([], []) - -collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs -collectCC cc ccs (c, cs) = (cc : c, ccs : cs) - -currentCCS, dontCareCCS :: CostCentreStack - -currentCCS = CurrentCCS -dontCareCCS = DontCareCCS - ------------------------------------------------------------------------------ --- Predicates on Cost-Centre Stacks - -isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False - -isCafCCS :: CostCentreStack -> Bool -isCafCCS (SingletonCCS cc) = isCafCC cc -isCafCCS _ = False - -maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre -maybeSingletonCCS (SingletonCCS cc) = Just cc -maybeSingletonCCS _ = Nothing - -mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = SingletonCCS cc - - ------------------------------------------------------------------------------ --- Printing Cost Centre Stacks. - --- The outputable instance for CostCentreStack prints the CCS as a C --- expression. - -instance Outputable CostCentreStack where - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" - - ------------------------------------------------------------------------------ --- Printing Cost Centres --- --- There are several different ways in which we might want to print a --- cost centre: --- --- - the name of the cost centre, for profiling output (a C string) --- - the label, i.e. C label for cost centre in .hc file. --- - the debugging name, for output in -ddump things --- - the interface name, for printing in _scc_ exprs in iface files. --- --- The last 3 are derived from costCentreStr below. The first is given --- by costCentreName. - -instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) - --- Printing in Core -pprCostCentreCore :: CostCentre -> SDoc -pprCostCentreCore (AllCafsCC {cc_mod = m}) - = text "__sccC" <+> braces (ppr m) -pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, - cc_mod = m, cc_loc = loc}) - = text "__scc" <+> braces (hsep [ - ppr m <> char '.' <> ftext n, - pprFlavourCore flavour, - whenPprDebug (ppr loc) - ]) - --- ^ Print a flavour in Core -pprFlavourCore :: CCFlavour -> SDoc -pprFlavourCore CafCC = text "__C" -pprFlavourCore f = pprIdxCore $ flavourIndex f - --- ^ Print a flavour's index in Core -pprIdxCore :: Int -> SDoc -pprIdxCore 0 = empty -pprIdxCore idx = whenPprDebug $ ppr idx - --- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" -ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> - ppFlavourLblComponent f <> text "_cc" - --- ^ Print the flavour component of a C label -ppFlavourLblComponent :: CCFlavour -> SDoc -ppFlavourLblComponent CafCC = text "CAF" -ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i -ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i -ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i - --- ^ Print the flavour index component of a C label -ppIdxLblComponent :: CostCentreIndex -> SDoc -ppIdxLblComponent n = - case unCostCentreIndex n of - 0 -> empty - n -> ppr n - --- This is the name to go in the user-displayed string, --- recorded in the cost centre declaration -costCentreUserName :: CostCentre -> String -costCentreUserName = unpackFS . costCentreUserNameFS - -costCentreUserNameFS :: CostCentre -> FastString -costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" -costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) - = case is_caf of - CafCC -> mkFastString "CAF:" `appendFS` name - _ -> name - -costCentreSrcSpan :: CostCentre -> SrcSpan -costCentreSrcSpan = cc_loc - -instance Binary CCFlavour where - put_ bh CafCC = do - putByte bh 0 - put_ bh (ExprCC i) = do - putByte bh 1 - put_ bh i - put_ bh (DeclCC i) = do - putByte bh 2 - put_ bh i - put_ bh (HpcCC i) = do - putByte bh 3 - put_ bh i - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - 1 -> ExprCC <$> get bh - 2 -> DeclCC <$> get bh - _ -> HpcCC <$> get bh - -instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (NormalCC aa ab ac noSrcSpan) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) - - -- We ignore the SrcSpans in CostCentres when we serialise them, - -- and set the SrcSpans to noSrcSpan when deserialising. This is - -- ok, because we only need the SrcSpan when declaring the - -- CostCentre in the original module, it is not used by importing - -- modules. diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs deleted file mode 100644 --- a/compiler/profiling/CostCentreState.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module CostCentreState ( CostCentreState, newCostCentreState - , CostCentreIndex, unCostCentreIndex, getCCIndex - ) where - -import GhcPrelude -import FastString -import FastStringEnv - -import Data.Data -import Binary - --- | Per-module state for tracking cost centre indices. --- --- See documentation of 'CostCentre.cc_flavour' for more details. -newtype CostCentreState = CostCentreState (FastStringEnv Int) - --- | Initialize cost centre state. -newCostCentreState :: CostCentreState -newCostCentreState = CostCentreState emptyFsEnv - --- | An index into a given cost centre module,name,flavour set -newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } - deriving (Eq, Ord, Data, Binary) - --- | Get a new index for a given cost centre name. -getCCIndex :: FastString - -> CostCentreState - -> (CostCentreIndex, CostCentreState) -getCCIndex nm (CostCentreState m) = - (CostCentreIndex idx, CostCentreState m') - where - m_idx = lookupFsEnv m nm - idx = maybe 0 id m_idx - m' = extendFsEnv m nm (idx + 1) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs deleted file mode 100644 --- a/compiler/simplCore/CoreMonad.hs +++ /dev/null @@ -1,838 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[CoreMonad]{The core pipeline monad} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module CoreMonad ( - -- * Configuration of the core-to-core passes - CoreToDo(..), runWhen, runMaybe, - SimplMode(..), - FloatOutSwitches(..), - pprPassDetails, - - -- * Plugins - CorePluginPass, bindsOnlyPass, - - -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, simplCountN, - pprSimplCount, plusSimplCount, zeroSimplCount, - isZeroSimplCount, hasDetailedCounts, Tick(..), - - -- * The monad - CoreM, runCoreM, - - -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, - getDynFlags, getOrigNameCache, getPackageFamInstEnv, - getVisibleOrphanMods, getUniqMask, - getPrintUnqualified, getSrcSpanM, - - -- ** Writing to the monad - addSimplCount, - - -- ** Lifting into the monad - liftIO, liftIOWithCount, - - -- ** Dealing with annotations - getAnnotations, getFirstAnnotations, - - -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, - fatalErrorMsg, fatalErrorMsgS, - debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn - ) where - -import GhcPrelude hiding ( read ) - -import GHC.Core -import GHC.Driver.Types -import Module -import GHC.Driver.Session -import BasicTypes ( CompilerPhase(..) ) -import Annotations - -import IOEnv hiding ( liftIO, failM, failWithM ) -import qualified IOEnv ( liftIO ) -import Var -import Outputable -import FastString -import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) -import UniqSupply -import MonadUtils -import NameCache -import NameEnv -import SrcLoc -import Data.Bifunctor ( bimap ) -import ErrUtils (dumpAction) -import Data.List (intersperse, groupBy, sortBy) -import Data.Ord -import Data.Dynamic -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict -import Data.Word -import Control.Monad -import Control.Applicative ( Alternative(..) ) -import Panic (throwGhcException, GhcException(..)) - -{- -************************************************************************ -* * - The CoreToDo type and related types - Abstraction of core-to-core passes to run. -* * -************************************************************************ --} - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - Int -- Max iterations - SimplMode - | CoreDoPluginPass String CorePluginPass - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoCallArity - | CoreDoExitify - | CoreDoDemand - | CoreDoCpr - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - | CoreDesugar -- Right after desugaring, no simple optimisation yet! - | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces - -- Core output, and hence useful to pass to endPass - - | CoreTidy - | CorePrep - | CoreOccurAnal - -instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = text "Simplifier" - ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s - ppr CoreDoFloatInwards = text "Float inwards" - ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) - ppr CoreLiberateCase = text "Liberate case" - ppr CoreDoStaticArgs = text "Static argument" - ppr CoreDoCallArity = text "Called arity analysis" - ppr CoreDoExitify = text "Exitification transformation" - ppr CoreDoDemand = text "Demand analysis" - ppr CoreDoCpr = text "Constructed Product Result analysis" - ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" - ppr CoreDoSpecialising = text "Specialise" - ppr CoreDoSpecConstr = text "SpecConstr" - ppr CoreCSE = text "Common sub-expression" - ppr CoreDesugar = text "Desugar (before optimization)" - ppr CoreDesugarOpt = text "Desugar (after optimization)" - ppr CoreTidy = text "Tidy Core" - ppr CorePrep = text "CorePrep" - ppr CoreOccurAnal = text "Occurrence analysis" - ppr CoreDoPrintCore = text "Print core" - ppr (CoreDoRuleCheck {}) = text "Rule check" - ppr CoreDoNothing = text "CoreDoNothing" - ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes - -pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n - , ppr md ] -pprPassDetails _ = Outputable.empty - -data SimplMode -- See comments in SimplMonad - = SimplMode - { sm_names :: [String] -- Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_dflags :: DynFlags -- Just for convenient non-monadic - -- access; we don't override these - , sm_rules :: Bool -- Whether RULES are enabled - , sm_inline :: Bool -- Whether inlining is enabled - , sm_case_case :: Bool -- Whether case-of-case is enabled - , sm_eta_expand :: Bool -- Whether eta-expansion is enabled - } - -instance Outputable SimplMode where - ppr (SimplMode { sm_phase = p, sm_names = ss - , sm_rules = r, sm_inline = i - , sm_eta_expand = eta, sm_case_case = cc }) - = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> - brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (sLit "inline") <> comma - , pp_flag r (sLit "rules") <> comma - , pp_flag eta (sLit "eta-expand") <> comma - , pp_flag cc (sLit "case-of-case") ]) - where - pp_flag f s = ppUnless f (text "no") <+> ptext s - -data FloatOutSwitches = FloatOutSwitches { - floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if - -- doing so will abstract over n or fewer - -- value variables - -- Nothing <=> float all lambdas to top level, - -- regardless of how many free variables - -- Just 0 is the vanilla case: float a lambda - -- iff it has no free vars - - floatOutConstants :: Bool, -- ^ True <=> float constants to top level, - -- even if they do not escape a lambda - floatOutOverSatApps :: Bool, - -- ^ True <=> float out over-saturated applications - -- based on arity information. - -- See Note [Floating over-saturated applications] - -- in SetLevels - floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. - } -instance Outputable FloatOutSwitches where - ppr = pprFloatOutSwitches - -pprFloatOutSwitches :: FloatOutSwitches -> SDoc -pprFloatOutSwitches sw - = text "FOS" <+> (braces $ - sep $ punctuate comma $ - [ text "Lam =" <+> ppr (floatOutLambdas sw) - , text "Consts =" <+> ppr (floatOutConstants sw) - , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) - --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - -{- - -************************************************************************ -* * - Types for Plugins -* * -************************************************************************ --} - --- | A description of the plugin pass itself -type CorePluginPass = ModGuts -> CoreM ModGuts - -bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts -bindsOnlyPass pass guts - = do { binds' <- pass (mg_binds guts) - ; return (guts { mg_binds = binds' }) } - -{- -************************************************************************ -* * - Counting and logging -* * -************************************************************************ --} - -getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = getPprDebug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -hasDetailedCounts :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount -doFreeSimplTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount - -data SimplCount - = VerySimplCount !Int -- Used when don't want detailed stats - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize, - -- most recent first - log2 :: [Tick] -- Last opt_HistorySize events before that - -- Having log1, log2 lets us accumulate the - -- recent history reasonably efficiently - } - -type TickCounts = Map Tick Int - -simplCountN :: SimplCount -> Int -simplCountN (VerySimplCount n) = n -simplCountN (SimplCount { ticks = n }) = n - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = Map.empty, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplCount 0 - -isZeroSimplCount (VerySimplCount n) = n==0 -isZeroSimplCount (SimplCount { ticks = n }) = n==0 - -hasDetailedCounts (VerySimplCount {}) = False -hasDetailedCounts (SimplCount {}) = True - -doFreeSimplTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeSimplTick _ sc = sc - -doSimplTick dflags tick - sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) - | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) - - -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = MapStrict.insertWith (+) tick 1 fm - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2 - , details = MapStrict.unionWith (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) -plusSimplCount lhs rhs = - throwGhcException . PprProgramError "plusSimplCount" $ vcat - [ text "lhs" - , pprSimplCount lhs - , text "rhs" - , pprSimplCount rhs - ] - -- We use one or the other consistently - -pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [text "Total ticks: " <+> int tks, - blankLine, - pprTickCounts dts, - getVerboseSimplStats $ \dbg -> if dbg - then - vcat [blankLine, - text "Log (most recent first)", - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else Outputable.empty - ] - -{- Note [Which transformations are innocuous] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one point (Jun 18) I wondered if some transformations (ticks) -might be "innocuous", in the sense that they do not unlock a later -transformation that does not occur in the same pass. If so, we could -refrain from bumping the overall tick-count for such innocuous -transformations, and perhaps terminate the simplifier one pass -earlier. - -BUt alas I found that virtually nothing was innocuous! This Note -just records what I learned, in case anyone wants to try again. - -These transformations are not innocuous: - -*** NB: I think these ones could be made innocuous - EtaExpansion - LetFloatFromLet - -LetFloatFromLet - x = K (let z = e2 in Just z) - prepareRhs transforms to - x2 = let z=e2 in Just z - x = K xs - And now more let-floating can happen in the - next pass, on x2 - -PreInlineUnconditionally - Example in spectral/cichelli/Auxil - hinsert = ...let lo = e in - let j = ...lo... in - case x of - False -> () - True -> case lo of I# lo' -> - ...j... - When we PreInlineUnconditionally j, lo's occ-info changes to once, - so it can be PreInlineUnconditionally in the next pass, and a - cascade of further things can happen. - -PostInlineUnconditionally - let x = e in - let y = ...x.. in - case .. of { A -> ...x...y... - B -> ...x...y... } - Current postinlineUnconditinaly will inline y, and then x; sigh. - - But PostInlineUnconditionally might also unlock subsequent - transformations for the same reason as PreInlineUnconditionally, - so it's probably not innocuous anyway. - -KnownBranch, BetaReduction: - May drop chunks of code, and thereby enable PreInlineUnconditionally - for some let-binding which now occurs once - -EtaExpansion: - Example in imaginary/digits-of-e1 - fail = \void. e where e :: IO () - --> etaExpandRhs - fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) - --> Next iteration of simplify - fail1 = \void. \s. (e |> g) s - fail = fail1 |> Void#->sym g - And now inline 'fail' - -CaseMerge: - case x of y { - DEFAULT -> case y of z { pi -> ei } - alts2 } - ---> CaseMerge - case x of { pi -> let z = y in ei - ; alts2 } - The "let z=y" case-binder-swap gets dealt with in the next pass --} - -pprTickCounts :: Map Tick Int -> SDoc -pprTickCounts counts - = vcat (map pprTickGroup groups) - where - groups :: [[(Tick,Int)]] -- Each group shares a common tag - -- toList returns common tags adjacent - groups = groupBy same_tag (Map.toList counts) - same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 - -pprTickGroup :: [(Tick, Int)] -> SDoc -pprTickGroup group@((tick1,_):_) - = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) - 2 (vcat [ int n <+> pprTickCts tick - -- flip as we want largest first - | (tick,n) <- sortBy (flip (comparing snd)) group]) -pprTickGroup [] = panic "pprTickGroup" - -data Tick -- See Note [Which transformations are innocuous] - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | SimplifierDone -- Ticked at each iteration of the simplifier - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = Outputable.empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = Outputable.empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ -> cmpEqTick a b - LT -> LT - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ - -{- -************************************************************************ -* * - Monad and carried data structure definitions -* * -************************************************************************ --} - -data CoreReader = CoreReader { - cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, - cr_module :: Module, - cr_print_unqual :: PrintUnqualified, - cr_loc :: SrcSpan, -- Use this for log/error messages so they - -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet, - cr_uniq_mask :: !Char -- Mask for creating unique values -} - --- Note: CoreWriter used to be defined with data, rather than newtype. If it --- is defined that way again, the cw_simpl_count field, at least, must be --- strict to avoid a space leak (#7702). -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -emptyWriter :: DynFlags -> CoreWriter -emptyWriter dflags = CoreWriter { - cw_simpl_count = zeroSimplCount dflags - } - -plusWriter :: CoreWriter -> CoreWriter -> CoreWriter -plusWriter w1 w2 = CoreWriter { - cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) - } - -type CoreIOEnv = IOEnv CoreReader - --- | The monad used by Core-to-Core passes to register simplification statistics. --- Also used to have common state (in the form of UniqueSupply) for generating Uniques. -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - deriving (Functor) - -instance Monad CoreM where - mx >>= f = CoreM $ do - (x, w1) <- unCoreM mx - (y, w2) <- unCoreM (f x) - let w = w1 `plusWriter` w2 - return $ seq w (y, w) - -- forcing w before building the tuple avoids a space leak - -- (#7702) - -instance Applicative CoreM where - pure x = CoreM $ nop x - (<*>) = ap - m *> k = m >>= \_ -> k - -instance Alternative CoreM where - empty = CoreM Control.Applicative.empty - m <|> n = CoreM (unCoreM m <|> unCoreM n) - -instance MonadPlus CoreM - -instance MonadUnique CoreM where - getUniqueSupplyM = do - mask <- read cr_uniq_mask - liftIO $! mkSplitUniqSupply mask - - getUniqueM = do - mask <- read cr_uniq_mask - liftIO $! uniqFromMask mask - -runCoreM :: HscEnv - -> RuleBase - -> Char -- ^ Mask - -> Module - -> ModuleSet - -> PrintUnqualified - -> SrcSpan - -> CoreM a - -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m - = liftM extract $ runIOEnv reader $ unCoreM m - where - reader = CoreReader { - cr_hsc_env = hsc_env, - cr_rule_base = rule_base, - cr_module = mod, - cr_visible_orphan_mods = orph_imps, - cr_print_unqual = print_unqual, - cr_loc = loc, - cr_uniq_mask = mask - } - - extract :: (a, CoreWriter) -> (a, SimplCount) - extract (value, writer) = (value, cw_simpl_count writer) - -{- -************************************************************************ -* * - Core combinators, not exported -* * -************************************************************************ --} - -nop :: a -> CoreIOEnv (a, CoreWriter) -nop x = do - r <- getEnv - return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) - -read :: (CoreReader -> a) -> CoreM a -read f = CoreM $ getEnv >>= (\r -> nop (f r)) - -write :: CoreWriter -> CoreM () -write w = CoreM $ return ((), w) - --- \subsection{Lifting IO into the monad} - --- | Lift an 'IOEnv' operation into 'CoreM' -liftIOEnv :: CoreIOEnv a -> CoreM a -liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) - -instance MonadIO CoreM where - liftIO = liftIOEnv . IOEnv.liftIO - --- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' -liftIOWithCount :: IO (SimplCount, a) -> CoreM a -liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) - -{- -************************************************************************ -* * - Reader, writer and state accessors -* * -************************************************************************ --} - -getHscEnv :: CoreM HscEnv -getHscEnv = read cr_hsc_env - -getRuleBase :: CoreM RuleBase -getRuleBase = read cr_rule_base - -getVisibleOrphanMods :: CoreM ModuleSet -getVisibleOrphanMods = read cr_visible_orphan_mods - -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual - -getSrcSpanM :: CoreM SrcSpan -getSrcSpanM = read cr_loc - -addSimplCount :: SimplCount -> CoreM () -addSimplCount count = write (CoreWriter { cw_simpl_count = count }) - -getUniqMask :: CoreM Char -getUniqMask = read cr_uniq_mask - --- Convenience accessors for useful fields of HscEnv - -instance HasDynFlags CoreM where - getDynFlags = fmap hsc_dflags getHscEnv - -instance HasModule CoreM where - getModule = read cr_module - --- | The original name cache is the current mapping from 'Module' and --- 'OccName' to a compiler-wide unique 'Name' -getOrigNameCache :: CoreM OrigNameCache -getOrigNameCache = do - nameCacheRef <- fmap hsc_NC getHscEnv - liftIO $ fmap nsNames $ readIORef nameCacheRef - -getPackageFamInstEnv :: CoreM PackageFamInstEnv -getPackageFamInstEnv = do - hsc_env <- getHscEnv - eps <- liftIO $ hscEPS hsc_env - return $ eps_fam_inst_env eps - -{- -************************************************************************ -* * - Dealing with annotations -* * -************************************************************************ --} - --- | Get all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). --- --- This should be done once at the start of a Core-to-Core pass that uses --- annotations. --- --- See Note [Annotations] -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) -getAnnotations deserialize guts = do - hsc_env <- getHscEnv - ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) - return (deserializeAnns deserialize ann_env) - --- | Get at most one annotation of a given type per annotatable item. -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) -getFirstAnnotations deserialize guts - = bimap mod name <$> getAnnotations deserialize guts - where - mod = mapModuleEnv head . filterModuleEnv (const $ not . null) - name = mapNameEnv head . filterNameEnv (not . null) - -{- -Note [Annotations] -~~~~~~~~~~~~~~~~~~ -A Core-to-Core pass that wants to make use of annotations calls -getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with -annotations of a specific type. This produces all annotations from interface -files read so far. However, annotations from interface files read during the -pass will not be visible until getAnnotations is called again. This is similar -to how rules work and probably isn't too bad. - -The current implementation could be optimised a bit: when looking up -annotations for a thing from the HomePackageTable, we could search directly in -the module where the thing is defined rather than building one UniqFM which -contains all annotations we know of. This would work because annotations can -only be given to things defined in the same module. However, since we would -only want to deserialise every annotation once, we would have to build a cache -for every module in the HTP. In the end, it's probably not worth it as long as -we aren't using annotations heavily. - -************************************************************************ -* * - Direct screen output -* * -************************************************************************ --} - -msg :: Severity -> WarnReason -> SDoc -> CoreM () -msg sev reason doc - = do { dflags <- getDynFlags - ; loc <- getSrcSpanM - ; unqual <- getPrintUnqualified - ; let sty = case sev of - SevError -> err_sty - SevWarning -> err_sty - SevDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle dflags unqual - user_sty = mkUserStyle dflags unqual AllTheWay - dump_sty = mkDumpStyle dflags unqual - ; liftIO $ putLogMsg dflags reason sev loc sty doc } - --- | Output a String message to the screen -putMsgS :: String -> CoreM () -putMsgS = putMsg . text - --- | Output a message to the screen -putMsg :: SDoc -> CoreM () -putMsg = msg SevInfo NoReason - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsgS :: String -> CoreM () -errorMsgS = errorMsg . text - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsg :: SDoc -> CoreM () -errorMsg = msg SevError NoReason - -warnMsg :: WarnReason -> SDoc -> CoreM () -warnMsg = msg SevWarning - --- | Output a fatal error to the screen. Does not cause the compiler to die. -fatalErrorMsgS :: String -> CoreM () -fatalErrorMsgS = fatalErrorMsg . text - --- | Output a fatal error to the screen. Does not cause the compiler to die. -fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg SevFatal NoReason - --- | Output a string debugging message at verbosity level of @-v@ or higher -debugTraceMsgS :: String -> CoreM () -debugTraceMsgS = debugTraceMsg . text - --- | Outputs a debugging message at verbosity level of @-v@ or higher -debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg SevDump NoReason - --- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher -dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () -dumpIfSet_dyn flag str fmt doc - = do { dflags <- getDynFlags - ; unqual <- getPrintUnqualified - ; when (dopt flag dflags) $ liftIO $ do - let sty = mkDumpStyle dflags unqual - dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc } diff --git a/compiler/simplCore/CoreMonad.hs-boot b/compiler/simplCore/CoreMonad.hs-boot deleted file mode 100644 --- a/compiler/simplCore/CoreMonad.hs-boot +++ /dev/null @@ -1,30 +0,0 @@ --- Created this hs-boot file to remove circular dependencies from the use of --- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core --- transformations. --- However CoreMonad does much more than defining these, and because Plugins are --- activated in various modules, the imports become circular. To solve this I --- extracted CoreToDo and CoreM into this file. --- I needed to write the whole definition of these types, otherwise it created --- a data-newtype conflict. - -module CoreMonad ( CoreToDo, CoreM ) where - -import GhcPrelude - -import IOEnv ( IOEnv ) - -type CoreIOEnv = IOEnv CoreReader - -data CoreReader - -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -data SimplCount - -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - -instance Monad CoreM - -data CoreToDo diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs deleted file mode 100644 --- a/compiler/simplCore/OccurAnal.hs +++ /dev/null @@ -1,2898 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[OccurAnal]{Occurrence analysis pass} -* * -************************************************************************ - -The occurrence analyser re-typechecks a core expression, returning a new -core expression with (hopefully) improved usage information. --} - -{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module OccurAnal ( - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - stripTicksTopE, mkTicks ) -import GHC.Core.Arity ( joinRhsArity ) -import Id -import IdInfo -import Name( localiseName ) -import BasicTypes -import Module( Module ) -import Coercion -import Type - -import VarSet -import VarEnv -import Var -import Demand ( argOneShots, argsOneShots ) -import Digraph ( SCC(..), Node(..) - , stronglyConnCompFromEdgedVerticesUniq - , stronglyConnCompFromEdgedVerticesUniqR ) -import Unique -import UniqFM -import UniqSet -import Util -import Outputable -import Data.List -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap -* * -************************************************************************ - -Here's the externally-callable interface: --} - -occurAnalysePgm :: Module -- Used only in debug output - -> (Id -> Bool) -- Active unfoldings - -> (Activation -> Bool) -- Active rules - -> [CoreRule] - -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_unf active_rule imp_rules binds - | isEmptyDetails final_usage - = occ_anald_binds - - | otherwise -- See Note [Glomming] - = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) - 2 (ppr final_usage ) ) - occ_anald_glommed_binds - where - init_env = initOccEnv { occ_rule_act = active_rule - , occ_unf_act = active_unf } - - (final_usage, occ_anald_binds) = go init_env binds - (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel - imp_rule_edges - (flattenBinds binds) - initial_uds - -- It's crucial to re-analyse the glommed-together bindings - -- so that we establish the right loop breakers. Otherwise - -- we can easily create an infinite loop (#9583 is an example) - -- - -- Also crucial to re-analyse the /original/ bindings - -- in case the first pass accidentally discarded as dead code - -- a binding that was actually needed (albeit before its - -- definition site). #17724 threw this up. - - initial_uds = addManyOccsSet emptyDetails - (rulesFreeVars imp_rules) - -- The RULES declarations keep things alive! - - -- Note [Preventing loops due to imported functions rules] - imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv - [ mapVarEnv (const maps_to) $ - getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) - | imp_rule <- imp_rules - , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] - , let maps_to = exprFreeIds (ru_rhs imp_rule) - `delVarSetList` ru_bndrs imp_rule - , arg <- ru_args imp_rule ] - - go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) - go _ [] - = (initial_uds, []) - go env (bind:binds) - = (final_usage, bind' ++ binds') - where - (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind - bs_usage - -occurAnalyseExpr :: CoreExpr -> CoreExpr - -- Do occurrence analysis, and discard occurrence info returned -occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap - -occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr -occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap - -occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr -occurAnalyseExpr' enable_binder_swap expr - = snd (occAnal env expr) - where - env = initOccEnv { occ_binder_swap = enable_binder_swap } - -{- Note [Plugin rules] -~~~~~~~~~~~~~~~~~~~~~~ -Conal Elliott (#11651) built a GHC plugin that added some -BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to -do some domain-specific transformations that could not be expressed -with an ordinary pattern-matching CoreRule. But then we can't extract -the dependencies (in imp_rule_edges) from ru_rhs etc, because a -BuiltinRule doesn't have any of that stuff. - -So we simply assume that BuiltinRules have no dependencies, and filter -them out from the imp_rule_edges comprehension. --} - -{- -************************************************************************ -* * - Bindings -* * -************************************************************************ - -Note [Recursive bindings: the grand plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a binding group - Rec { x1 = r1; ...; xn = rn } -we treat it like this (occAnalRecBind): - -1. Occurrence-analyse each right hand side, and build a - "Details" for each binding to capture the results. - - Wrap the details in a Node (details, node-id, dep-node-ids), - where node-id is just the unique of the binder, and - dep-node-ids lists all binders on which this binding depends. - We'll call these the "scope edges". - See Note [Forming the Rec groups]. - - All this is done by makeNode. - -2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or - NonRec. The key property is that every free variable of a binding - is accounted for by the scope edges, so that when we are done - everything is still in scope. - -3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we - identify suitable loop-breakers to ensure that inlining terminates. - This is done by occAnalRec. - -4. To do so we form a new set of Nodes, with the same details, but - different edges, the "loop-breaker nodes". The loop-breaker nodes - have both more and fewer dependencies than the scope edges - (see Note [Choosing loop breakers]) - - More edges: if f calls g, and g has an active rule that mentions h - then we add an edge from f -> h - - Fewer edges: we only include dependencies on active rules, on rule - RHSs (not LHSs) and if there is an INLINE pragma only - on the stable unfolding (and vice versa). The scope - edges must be much more inclusive. - -5. The "weak fvs" of a node are, by definition: - the scope fvs - the loop-breaker fvs - See Note [Weak loop breakers], and the nd_weak field of Details - -6. Having formed the loop-breaker nodes - -Note [Dead code] -~~~~~~~~~~~~~~~~ -Dropping dead code for a cyclic Strongly Connected Component is done -in a very simple way: - - the entire SCC is dropped if none of its binders are mentioned - in the body; otherwise the whole thing is kept. - -The key observation is that dead code elimination happens after -dependency analysis: so 'occAnalBind' processes SCCs instead of the -original term's binding groups. - -Thus 'occAnalBind' does indeed drop 'f' in an example like - - letrec f = ...g... - g = ...(...g...)... - in - ...g... - -when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in -'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes -'AcyclicSCC f', where 'body_usage' won't contain 'f'. - ------------------------------------------------------------- -Note [Forming Rec groups] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We put bindings {f = ef; g = eg } in a Rec group if "f uses g" -and "g uses f", no matter how indirectly. We do a SCC analysis -with an edge f -> g if "f uses g". - -More precisely, "f uses g" iff g should be in scope wherever f is. -That is, g is free in: - a) the rhs 'ef' - b) or the RHS of a rule for f (Note [Rules are extra RHSs]) - c) or the LHS or a rule for f (Note [Rule dependency info]) - -These conditions apply regardless of the activation of the RULE (eg it might be -inactive in this phase but become active later). Once a Rec is broken up -it can never be put back together, so we must be conservative. - -The principle is that, regardless of rule firings, every variable is -always in scope. - - * Note [Rules are extra RHSs] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" - keeps the specialised "children" alive. If the parent dies - (because it isn't referenced any more), then the children will die - too (unless they are already referenced directly). - - To that end, we build a Rec group for each cyclic strongly - connected component, - *treating f's rules as extra RHSs for 'f'*. - More concretely, the SCC analysis runs on a graph with an edge - from f -> g iff g is mentioned in - (a) f's rhs - (b) f's RULES - These are rec_edges. - - Under (b) we include variables free in *either* LHS *or* RHS of - the rule. The former might seems silly, but see Note [Rule - dependency info]. So in Example [eftInt], eftInt and eftIntFB - will be put in the same Rec, even though their 'main' RHSs are - both non-recursive. - - * Note [Rule dependency info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a RuleInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. - Why both? Consider - x = y - RULE f x = v+4 - Then if we substitute y for x, we'd better do so in the - rule's LHS too, so we'd better ensure the RULE appears to mention 'x' - as well as 'v' - - * Note [Rules are visible in their own rec group] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We want the rules for 'f' to be visible in f's right-hand side. - And we'd like them to be visible in other functions in f's Rec - group. E.g. in Note [Specialisation rules] we want f' rule - to be visible in both f's RHS, and fs's RHS. - - This means that we must simplify the RULEs first, before looking - at any of the definitions. This is done by Simplify.simplRecBind, - when it calls addLetIdInfo. - ------------------------------------------------------------- -Note [Choosing loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Loop breaking is surprisingly subtle. First read the section 4 of -"Secrets of the GHC inliner". This describes our basic plan. -We avoid infinite inlinings by choosing loop breakers, and -ensuring that a loop breaker cuts each loop. - -See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which -deals with a closely related source of infinite loops. - -Fundamentally, we do SCC analysis on a graph. For each recursive -group we choose a loop breaker, delete all edges to that node, -re-analyse the SCC, and iterate. - -But what is the graph? NOT the same graph as was used for Note -[Forming Rec groups]! In particular, a RULE is like an equation for -'f' that is *always* inlined if it is applicable. We do *not* disable -rules for loop-breakers. It's up to whoever makes the rules to make -sure that the rules themselves always terminate. See Note [Rules for -recursive functions] in Simplify.hs - -Hence, if - f's RHS (or its INLINE template if it has one) mentions g, and - g has a RULE that mentions h, and - h has a RULE that mentions f - -then we *must* choose f to be a loop breaker. Example: see Note -[Specialisation rules]. - -In general, take the free variables of f's RHS, and augment it with -all the variables reachable by RULES from those starting points. That -is the whole reason for computing rule_fv_env in occAnalBind. (Of -course we only consider free vars that are also binders in this Rec -group.) See also Note [Finding rule RHS free vars] - -Note that when we compute this rule_fv_env, we only consider variables -free in the *RHS* of the rule, in contrast to the way we build the -Rec group in the first place (Note [Rule dependency info]) - -Note that if 'g' has RHS that mentions 'w', we should add w to -g's loop-breaker edges. More concretely there is an edge from f -> g -iff - (a) g is mentioned in f's RHS `xor` f's INLINE rhs - (see Note [Inline rules]) - (b) or h is mentioned in f's RHS, and - g appears in the RHS of an active RULE of h - or a transitive sequence of active rules starting with h - -Why "active rules"? See Note [Finding rule RHS free vars] - -Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is -chosen as a loop breaker, because their RHSs don't mention each other. -And indeed both can be inlined safely. - -Note again that the edges of the graph we use for computing loop breakers -are not the same as the edges we use for computing the Rec blocks. -That's why we compute - -- rec_edges for the Rec block analysis -- loop_breaker_nodes for the loop breaker analysis - - * Note [Finding rule RHS free vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider this real example from Data Parallel Haskell - tagZero :: Array Int -> Array Tag - {-# INLINE [1] tagZeroes #-} - tagZero xs = pmap (\x -> fromBool (x==0)) xs - - {-# RULES "tagZero" [~1] forall xs n. - pmap fromBool = tagZero xs #-} - So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. - However, tagZero can only be inlined in phase 1 and later, while - the RULE is only active *before* phase 1. So there's no problem. - - To make this work, we look for the RHS free vars only for - *active* rules. That's the reason for the occ_rule_act field - of the OccEnv. - - * Note [Weak loop breakers] - ~~~~~~~~~~~~~~~~~~~~~~~~~ - There is a last nasty wrinkle. Suppose we have - - Rec { f = f_rhs - RULE f [] = g - - h = h_rhs - g = h - ...more... - } - - Remember that we simplify the RULES before any RHS (see Note - [Rules are visible in their own rec group] above). - - So we must *not* postInlineUnconditionally 'g', even though - its RHS turns out to be trivial. (I'm assuming that 'g' is - not chosen as a loop breaker.) Why not? Because then we - drop the binding for 'g', which leaves it out of scope in the - RULE! - - Here's a somewhat different example of the same thing - Rec { g = h - ; h = ...f... - ; f = f_rhs - RULE f [] = g } - Here the RULE is "below" g, but we *still* can't postInlineUnconditionally - g, because the RULE for f is active throughout. So the RHS of h - might rewrite to h = ...g... - So g must remain in scope in the output program! - - We "solve" this by: - - Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) - iff g is a "missing free variable" of the Rec group - - A "missing free variable" x is one that is mentioned in an RHS or - INLINE or RULE of a binding in the Rec group, but where the - dependency on x may not show up in the loop_breaker_nodes (see - note [Choosing loop breakers} above). - - A normal "strong" loop breaker has IAmLoopBreaker False. So - - Inline postInlineUnconditionally - strong IAmLoopBreaker False no no - weak IAmLoopBreaker True yes no - other yes yes - - The **sole** reason for this kind of loop breaker is so that - postInlineUnconditionally does not fire. Ugh. (Typically it'll - inline via the usual callSiteInline stuff, so it'll be dead in the - next pass, so the main Ugh is the tiresome complication.) - -Note [Rules for imported functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - f = /\a. B.g a - RULE B.g Int = 1 + f Int -Note that - * The RULE is for an imported function. - * f is non-recursive -Now we -can get - f Int --> B.g Int Inlining f - --> 1 + f Int Firing RULE -and so the simplifier goes into an infinite loop. This -would not happen if the RULE was for a local function, -because we keep track of dependencies through rules. But -that is pretty much impossible to do for imported Ids. Suppose -f's definition had been - f = /\a. C.h a -where (by some long and devious process), C.h eventually inlines to -B.g. We could only spot such loops by exhaustively following -unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) -f. - -Note that RULES for imported functions are important in practice; they -occur a lot in the libraries. - -We regard this potential infinite loop as a *programmer* error. -It's up the programmer not to write silly rules like - RULE f x = f x -and the example above is just a more complicated version. - -Note [Preventing loops due to imported functions rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - import GHC.Base (foldr) - - {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} - filter p xs = build (\c n -> foldr (filterFB c p) n xs) - filterFB c p = ... - - f = filter p xs - -Note that filter is not a loop-breaker, so what happens is: - f = filter p xs - = {inline} build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -We are in an infinite loop. - -A more elaborate example (that I actually saw in practice when I went to -mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: - {-# LANGUAGE RankNTypes #-} - module GHCList where - - import Prelude hiding (filter) - import GHC.Base (build) - - {-# INLINABLE filter #-} - filter :: (a -> Bool) -> [a] -> [a] - filter p [] = [] - filter p (x:xs) = if p x then x : filter p xs else filter p xs - - {-# NOINLINE [0] filterFB #-} - filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b - filterFB c p x r | p x = x `c` r - | otherwise = r - - {-# RULES - "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr - (filterFB c p) n xs) - "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p - #-} - -Then (because RULES are applied inside INLINABLE unfoldings, but inlinings -are not), the unfolding given to "filter" in the interface file will be: - filter p [] = [] - filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs - -Note that because this unfolding does not mention "filter", filter is not -marked as a strong loop breaker. Therefore at a use site in another module: - filter p xs - = {inline} - case xs of [] -> [] - (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs) - - build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -And we are in an infinite loop again, except that this time the loop is producing an -infinitely large *term* (an unrolling of filter) and so the simplifier finally -dies with "ticks exhausted" - -Because of this problem, we make a small change in the occurrence analyser -designed to mark functions like "filter" as strong loop breakers on the basis that: - 1. The RHS of filter mentions the local function "filterFB" - 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS - -So for each RULE for an *imported* function we are going to add -dependency edges between the *local* FVS of the rule LHS and the -*local* FVS of the rule RHS. We don't do anything special for RULES on -local functions because the standard occurrence analysis stuff is -pretty good at getting loop-breakerness correct there. - -It is important to note that even with this extra hack we aren't always going to get -things right. For example, it might be that the rule LHS mentions an imported Id, -and another module has a RULE that can rewrite that imported Id to one of our local -Ids. - -Note [Specialising imported functions] (referred to from Specialise) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT for *automatically-generated* rules, the programmer can't be -responsible for the "programmer error" in Note [Rules for imported -functions]. In particular, consider specialising a recursive function -defined in another module. If we specialise a recursive function B.g, -we get - g_spec = .....(B.g Int)..... - RULE B.g Int = g_spec -Here, g_spec doesn't look recursive, but when the rule fires, it -becomes so. And if B.g was mutually recursive, the loop might -not be as obvious as it is here. - -To avoid this, - * When specialising a function that is a loop breaker, - give a NOINLINE pragma to the specialised function - -Note [Glomming] -~~~~~~~~~~~~~~~ -RULES for imported Ids can make something at the top refer to something at the bottom: - f = \x -> B.g (q x) - h = \y -> 3 - - RULE: B.g (q x) = h x - -Applying this rule makes f refer to h, although f doesn't appear to -depend on h. (And, as in Note [Rules for imported functions], the -dependency might be more indirect. For example, f might mention C.t -rather than B.g, where C.t eventually inlines to B.g.) - -NOTICE that this cannot happen for rules whose head is a -locally-defined function, because we accurately track dependencies -through RULES. It only happens for rules whose head is an imported -function (B.g in the example above). - -Solution: - - When simplifying, bring all top level identifiers into - scope at the start, ignoring the Rec/NonRec structure, so - that when 'h' pops up in f's rhs, we find it in the in-scope set - (as the simplifier generally expects). This happens in simplTopBinds. - - - In the occurrence analyser, if there are any out-of-scope - occurrences that pop out of the top, which will happen after - firing the rule: f = \x -> h x - h = \y -> 3 - then just glom all the bindings into a single Rec, so that - the *next* iteration of the occurrence analyser will sort - them all out. This part happens in occurAnalysePgm. - ------------------------------------------------------------- -Note [Inline rules] -~~~~~~~~~~~~~~~~~~~ -None of the above stuff about RULES applies to Inline Rules, -stored in a CoreUnfolding. The unfolding, if any, is simplified -at the same time as the regular RHS of the function (ie *not* like -Note [Rules are visible in their own rec group]), so it should be -treated *exactly* like an extra RHS. - -Or, rather, when computing loop-breaker edges, - * If f has an INLINE pragma, and it is active, we treat the - INLINE rhs as f's rhs - * If it's inactive, we treat f as having no rhs - * If it has no INLINE pragma, we look at f's actual rhs - - -There is a danger that we'll be sub-optimal if we see this - f = ...f... - [INLINE f = ..no f...] -where f is recursive, but the INLINE is not. This can just about -happen with a sufficiently odd set of rules; eg - - foo :: Int -> Int - {-# INLINE [1] foo #-} - foo x = x+1 - - bar :: Int -> Int - {-# INLINE [1] bar #-} - bar x = foo x + 1 - - {-# RULES "foo" [~1] forall x. foo x = bar x #-} - -Here the RULE makes bar recursive; but it's INLINE pragma remains -non-recursive. It's tempting to then say that 'bar' should not be -a loop breaker, but an attempt to do so goes wrong in two ways: - a) We may get - $df = ...$cfoo... - $cfoo = ...$df.... - [INLINE $cfoo = ...no-$df...] - But we want $cfoo to depend on $df explicitly so that we - put the bindings in the right order to inline $df in $cfoo - and perhaps break the loop altogether. (Maybe this - b) - - -Example [eftInt] -~~~~~~~~~~~~~~~ -Example (from GHC.Enum): - - eftInt :: Int# -> Int# -> [Int] - eftInt x y = ...(non-recursive)... - - {-# INLINE [0] eftIntFB #-} - eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r - eftIntFB c n x y = ...(non-recursive)... - - {-# RULES - "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) - "eftIntList" [1] eftIntFB (:) [] = eftInt - #-} - -Note [Specialisation rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this group, which is typical of what SpecConstr builds: - - fs a = ....f (C a).... - f x = ....f (C a).... - {-# RULE f (C a) = fs a #-} - -So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). - -But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - - fs is inlined (say it's small) - - now there's another opportunity to apply the RULE - -This showed up when compiling Control.Concurrent.Chan.getChanContents. - ------------------------------------------------------------- -Note [Finding join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's the occurrence analyser's job to find bindings that we can turn into join -points, but it doesn't perform that transformation right away. Rather, it marks -the eligible bindings as part of their occurrence data, leaving it to the -simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. -The simplifier then eta-expands the RHS if needed and then updates the -occurrence sites. Dividing the work this way means that the occurrence analyser -still only takes one pass, yet one can always tell the difference between a -function call and a jump by looking at the occurrence (because the same pass -changes the 'IdDetails' and propagates the binders to their occurrence sites). - -To track potential join points, we use the 'occ_tail' field of OccInfo. A value -of `AlwaysTailCalled n` indicates that every occurrence of the variable is a -tail call with `n` arguments (counting both value and type arguments). Otherwise -'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the -rest of 'OccInfo' until it goes on the binder. - -Note [Rules and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Things get fiddly with rules. Suppose we have: - - let j :: Int -> Int - j y = 2 * y - k :: Int -> Int -> Int - {-# RULES "SPEC k 0" k 0 = j #-} - k x y = x + 2 * y - in ... - -Now suppose that both j and k appear only as saturated tail calls in the body. -Thus we would like to make them both join points. The rule complicates matters, -though, as its RHS has an unapplied occurrence of j. *However*, if we were to -eta-expand the rule, all would be well: - - {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} - -So conceivably we could notice that a potential join point would have an -"undersaturated" rule and account for it. This would mean we could make -something that's been specialised a join point, for instance. But local bindings -are rarely specialised, and being overly cautious about rules only -costs us anything when, for some `j`: - - * Before specialisation, `j` has non-tail calls, so it can't be a join point. - * During specialisation, `j` gets specialised and thus acquires rules. - * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), - and so now `j` *could* become a join point. - -This appears to be very rare in practice. TODO Perhaps we should gather -statistics to be sure. - ------------------------------------------------------------- -Note [Adjusting right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a dance we need to do after analysing a lambda expression or -a right-hand side. In particular, we need to - - a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot - lambda, or a non-recursive join point; and - b) call 'markAllNonTailCalled' *unless* the binding is for a join point. - -Some examples, with how the free occurrences in e (assumed not to be a value -lambda) get marked: - - inside lam non-tail-called - ------------------------------------------------------------ - let x = e No Yes - let f = \x -> e Yes Yes - let f = \x{OneShot} -> e No Yes - \x -> e Yes Yes - join j x = e No No - joinrec j x = e Yes No - -There are a few other caveats; most importantly, if we're marking a binding as -'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so -that the effect cascades properly. Consequently, at the time the RHS is -analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must -return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once -join-point-hood has been decided. - -Thus the overall sequence taking place in 'occAnalNonRecBind' and -'occAnalRecBind' is as follows: - - 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. - 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make - the binding a join point. - 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when - recursive.) - -(In the recursive case, this logic is spread between 'makeNode' and -'occAnalRec'.) --} - ------------------------------------------------------------------- --- occAnalBind ------------------------------------------------------------------- - -occAnalBind :: OccEnv -- The incoming OccEnv - -> TopLevelFlag - -> ImpRuleEdges - -> CoreBind - -> UsageDetails -- Usage details of scope - -> (UsageDetails, -- Of the whole let(rec) - [CoreBind]) - -occAnalBind env lvl top_env (NonRec binder rhs) body_usage - = occAnalNonRecBind env lvl top_env binder rhs body_usage -occAnalBind env lvl top_env (Rec pairs) body_usage - = occAnalRecBind env lvl top_env pairs body_usage - ------------------ -occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr - -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage - | isTyVar binder -- A type let; we don't gather usage info - = (body_usage, [NonRec binder rhs]) - - | not (binder `usedIn` body_usage) -- It's not mentioned - = (body_usage, []) - - | otherwise -- It's mentioned in the body - = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs']) - where - (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder - mb_join_arity = willBeJoinId_maybe tagged_binder - - (bndrs, body) = collectBinders rhs - - (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body - rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' - -- For a /non-recursive/ join point we can mark all - -- its join-lambda as one-shot; and it's a good idea to do so - - -- Unfoldings - -- See Note [Unfoldings and join points] - rhs_usage2 = case occAnalUnfolding env NonRecursive binder of - Just unf_usage -> rhs_usage1 `andUDs` unf_usage - Nothing -> rhs_usage1 - - -- Rules - -- See Note [Rules are extra RHSs] and Note [Rule dependency info] - rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder - rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds - rhs_usage3 = foldr andUDs rhs_usage2 rule_uds - rhs_usage4 = case lookupVarEnv imp_rule_edges binder of - Nothing -> rhs_usage3 - Just vs -> addManyOccsSet rhs_usage3 vs - -- See Note [Preventing loops due to imported functions rules] - - -- Final adjustment - rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 - ------------------ -occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] - -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalRecBind env lvl imp_rule_edges pairs body_usage - = foldr (occAnalRec env lvl) (body_usage, []) sccs - -- For a recursive group, we - -- * occ-analyse all the RHSs - -- * compute strongly-connected components - -- * feed those components to occAnalRec - -- See Note [Recursive bindings: the grand plan] - where - sccs :: [SCC Details] - sccs = {-# SCC "occAnalBind.scc" #-} - stronglyConnCompFromEdgedVerticesUniq nodes - - nodes :: [LetrecNode] - nodes = {-# SCC "occAnalBind.assoc" #-} - map (makeNode env imp_rule_edges bndr_set) pairs - - bndr_set = mkVarSet (map fst pairs) - -{- -Note [Unfoldings and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We assume that anything in an unfolding occurs multiple times, since unfoldings -are often copied (that's the whole point!). But we still need to track tail -calls for the purpose of finding join points. --} - ------------------------------ -occAnalRec :: OccEnv -> TopLevelFlag - -> SCC Details - -> (UsageDetails, [CoreBind]) - -> (UsageDetails, [CoreBind]) - - -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs - , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) - (body_uds, binds) - | not (bndr `usedIn` body_uds) - = (body_uds, binds) -- See Note [Dead code] - - | otherwise -- It's mentioned in the body - = (body_uds' `andUDs` rhs_uds', - NonRec tagged_bndr rhs : binds) - where - (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr - rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive - rhs_bndrs rhs_uds - - -- The Rec case is the interesting one - -- See Note [Recursive bindings: the grand plan] - -- See Note [Loop breaking] -occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) - | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds - = (body_uds, binds) -- See Note [Dead code] - - | otherwise -- At this point we always build a single Rec - = -- pprTrace "occAnalRec" (vcat - -- [ text "weak_fvs" <+> ppr weak_fvs - -- , text "lb nodes" <+> ppr loop_breaker_nodes]) - (final_uds, Rec pairs : binds) - - where - bndrs = map nd_bndr details_s - bndr_set = mkVarSet bndrs - - ------------------------------ - -- See Note [Choosing loop breakers] for loop_breaker_nodes - final_uds :: UsageDetails - loop_breaker_nodes :: [LetrecNode] - (final_uds, loop_breaker_nodes) - = mkLoopBreakerNodes env lvl bndr_set body_uds details_s - - ------------------------------ - weak_fvs :: VarSet - weak_fvs = mapUnionVarSet nd_weak details_s - - --------------------------- - -- Now reconstruct the cycle - pairs :: [(Id,CoreExpr)] - pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] - | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] - -- If weak_fvs is empty, the loop_breaker_nodes will include - -- all the edges in the original scope edges [remember, - -- weak_fvs is the difference between scope edges and - -- lb-edges], so a fresh SCC computation would yield a - -- single CyclicSCC result; and reOrderNodes deals with - -- exactly that case - - ------------------------------------------------------------------- --- Loop breaking ------------------------------------------------------------------- - -type Binding = (Id,CoreExpr) - -loopBreakNodes :: Int - -> VarSet -- All binders - -> VarSet -- Binders whose dependencies may be "missing" - -- See Note [Weak loop breakers] - -> [LetrecNode] - -> [Binding] -- Append these to the end - -> [Binding] -{- -loopBreakNodes is applied to the list of nodes for a cyclic strongly -connected component (there's guaranteed to be a cycle). It returns -the same nodes, but - a) in a better order, - b) with some of the Ids having a IAmALoopBreaker pragma - -The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means -that the simplifier can guarantee not to loop provided it never records an inlining -for these no-inline guys. - -Furthermore, the order of the binds is such that if we neglect dependencies -on the no-inline Ids then the binds are topologically sorted. This means -that the simplifier will generally do a good job if it works from top bottom, -recording inlinings for any Ids which aren't marked as "no-inline" as it goes. --} - --- Return the bindings sorted into a plausible order, and marked with loop breakers. -loopBreakNodes depth bndr_set weak_fvs nodes binds - = -- pprTrace "loopBreakNodes" (ppr nodes) $ - go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds - where - go [] binds = binds - go (scc:sccs) binds = loop_break_scc scc (go sccs binds) - - loop_break_scc scc binds - = case scc of - AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds - CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds - ----------------------------------- -reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] - -- Choose a loop breaker, mark it no-inline, - -- and call loopBreakNodes on the rest -reOrderNodes _ _ _ [] _ = panic "reOrderNodes" -reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds -reOrderNodes depth bndr_set weak_fvs (node : nodes) binds - = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen - -- , text "chosen" <+> ppr chosen_nodes ]) $ - loopBreakNodes new_depth bndr_set weak_fvs unchosen $ - (map mk_loop_breaker chosen_nodes ++ binds) - where - (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb - (nd_score (node_payload node)) - [node] [] nodes - - approximate_lb = depth >= 2 - new_depth | approximate_lb = 0 - | otherwise = depth+1 - -- After two iterations (d=0, d=1) give up - -- and approximate, returning to d=0 - -mk_loop_breaker :: LetrecNode -> Binding -mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs}) - = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) - where - tail_info = tailCallInfo (idOccInfo bndr) - -mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding --- See Note [Weak loop breakers] -mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr - , nd_rhs = rhs}) - | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) - | otherwise = (bndr, rhs) - where - occ' = weakLoopBreaker { occ_tail = tail_info } - tail_info = tailCallInfo (idOccInfo bndr) - ----------------------------------- -chooseLoopBreaker :: Bool -- True <=> Too many iterations, - -- so approximate - -> NodeScore -- Best score so far - -> [LetrecNode] -- Nodes with this score - -> [LetrecNode] -- Nodes with higher scores - -> [LetrecNode] -- Unprocessed nodes - -> ([LetrecNode], [LetrecNode]) - -- This loop looks for the bind with the lowest score - -- to pick as the loop breaker. The rest accumulate in -chooseLoopBreaker _ _ loop_nodes acc [] - = (loop_nodes, acc) -- Done - - -- If approximate_loop_breaker is True, we pick *all* - -- nodes with lowest score, else just one - -- See Note [Complexity of loop breaking] -chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) - | approx_lb - , rank sc == rank loop_sc - = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes - - | sc `betterLB` loop_sc -- Better score so pick this new one - = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes - - | otherwise -- Worse score so don't pick it - = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes - where - sc = nd_score (node_payload node) - -{- -Note [Complexity of loop breaking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The loop-breaking algorithm knocks out one binder at a time, and -performs a new SCC analysis on the remaining binders. That can -behave very badly in tightly-coupled groups of bindings; in the -worst case it can be (N**2)*log N, because it does a full SCC -on N, then N-1, then N-2 and so on. - -To avoid this, we switch plans after 2 (or whatever) attempts: - Plan A: pick one binder with the lowest score, make it - a loop breaker, and try again - Plan B: pick *all* binders with the lowest score, make them - all loop breakers, and try again -Since there are only a small finite number of scores, this will -terminate in a constant number of iterations, rather than O(N) -iterations. - -You might thing that it's very unlikely, but RULES make it much -more likely. Here's a real example from #1969: - Rec { $dm = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm1 - forall d. $dm Bool d = $s$dm2 #-} - - dInt = MkD .... opInt ... - dInt = MkD .... opBool ... - opInt = $dm dInt - opBool = $dm dBool - - $s$dm1 = \x. op dInt - $s$dm2 = \x. op dBool } -The RULES stuff means that we can't choose $dm as a loop breaker -(Note [Choosing loop breakers]), so we must choose at least (say) -opInt *and* opBool, and so on. The number of loop breakders is -linear in the number of instance declarations. - -Note [Loop breakers and INLINE/INLINABLE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Avoid choosing a function with an INLINE pramga as the loop breaker! -If such a function is mutually-recursive with a non-INLINE thing, -then the latter should be the loop-breaker. - -It's vital to distinguish between INLINE and INLINABLE (the -Bool returned by hasStableCoreUnfolding_maybe). If we start with - Rec { {-# INLINABLE f #-} - f x = ...f... } -and then worker/wrapper it through strictness analysis, we'll get - Rec { {-# INLINABLE $wf #-} - $wf p q = let x = (p,q) in ...f... - - {-# INLINE f #-} - f x = case x of (p,q) -> $wf p q } - -Now it is vital that we choose $wf as the loop breaker, so we can -inline 'f' in '$wf'. - -Note [DFuns should not be loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's particularly bad to make a DFun into a loop breaker. See -Note [How instance declarations are translated] in TcInstDcls - -We give DFuns a higher score than ordinary CONLIKE things because -if there's a choice we want the DFun to be the non-loop breaker. Eg - -rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) - - $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) - {-# DFUN #-} - $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) - } - -Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it -if we can't unravel the DFun first. - -Note [Constructor applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really really important to inline dictionaries. Real -example (the Enum Ordering instance from GHC.Base): - - rec f = \ x -> case d of (p,q,r) -> p x - g = \ x -> case d of (p,q,r) -> q x - d = (v, f, g) - -Here, f and g occur just once; but we can't inline them into d. -On the other hand we *could* simplify those case expressions if -we didn't stupidly choose d as the loop breaker. -But we won't because constructor args are marked "Many". -Inlining dictionaries is really essential to unravelling -the loops in static numeric dictionaries, see GHC.Float. - -Note [Closure conversion] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. -The immediate motivation came from the result of a closure-conversion transformation -which generated code like this: - - data Clo a b = forall c. Clo (c -> a -> b) c - - ($:) :: Clo a b -> a -> b - Clo f env $: x = f env x - - rec { plus = Clo plus1 () - - ; plus1 _ n = Clo plus2 n - - ; plus2 Zero n = n - ; plus2 (Succ m) n = Succ (plus $: m $: n) } - -If we inline 'plus' and 'plus1', everything unravels nicely. But if -we choose 'plus1' as the loop breaker (which is entirely possible -otherwise), the loop does not unravel nicely. - - -@occAnalUnfolding@ deals with the question of bindings where the Id is marked -by an INLINE pragma. For these we record that anything which occurs -in its RHS occurs many times. This pessimistically assumes that this -inlined binder also occurs many times in its scope, but if it doesn't -we'll catch it next time round. At worst this costs an extra simplifier pass. -ToDo: try using the occurrence info for the inline'd binder. - -[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. -[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. - - -************************************************************************ -* * - Making nodes -* * -************************************************************************ --} - -type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs - -noImpRuleEdges :: ImpRuleEdges -noImpRuleEdges = emptyVarEnv - -type LetrecNode = Node Unique Details -- Node comes from Digraph - -- The Unique key is gotten from the Id -data Details - = ND { nd_bndr :: Id -- Binder - , nd_rhs :: CoreExpr -- RHS, already occ-analysed - , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS - -- INVARIANT: (nd_rhs_bndrs nd, _) == - -- collectBinders (nd_rhs nd) - - , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings - -- ignoring phase (ie assuming all are active) - -- See Note [Forming Rec groups] - - , nd_inl :: IdSet -- Free variables of - -- the stable unfolding (if present and active) - -- or the RHS (if not) - -- but excluding any RULES - -- This is the IdSet that may be used if the Id is inlined - - , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds - -- but are *not* in nd_inl. These are the ones whose - -- dependencies might not be respected by loop_breaker_nodes - -- See Note [Weak loop breakers] - - , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES - - , nd_score :: NodeScore - } - -instance Outputable Details where - ppr nd = text "ND" <> braces - (sep [ text "bndr =" <+> ppr (nd_bndr nd) - , text "uds =" <+> ppr (nd_uds nd) - , text "inl =" <+> ppr (nd_inl nd) - , text "weak =" <+> ppr (nd_weak nd) - , text "rule =" <+> ppr (nd_active_rule_fvs nd) - , text "score =" <+> ppr (nd_score nd) - ]) - --- The NodeScore is compared lexicographically; --- e.g. lower rank wins regardless of size -type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker - , Int -- Size of rhs: higher => more likely to be picked as LB - -- Maxes out at maxExprSize; we just use it to prioritise - -- small functions - , Bool ) -- Was it a loop breaker before? - -- True => more likely to be picked - -- Note [Loop breakers, node scoring, and stability] - -rank :: NodeScore -> Int -rank (r, _, _) = r - -makeNode :: OccEnv -> ImpRuleEdges -> VarSet - -> (Var, CoreExpr) -> LetrecNode --- See Note [Recursive bindings: the grand plan] -makeNode env imp_rule_edges bndr_set (bndr, rhs) - = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) - -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR - -- is still deterministic with edges in nondeterministic order as - -- explained in Note [Deterministic SCC] in Digraph. - where - details = ND { nd_bndr = bndr - , nd_rhs = rhs' - , nd_rhs_bndrs = bndrs' - , nd_uds = rhs_usage3 - , nd_inl = inl_fvs - , nd_weak = node_fvs `minusVarSet` inl_fvs - , nd_active_rule_fvs = active_rule_fvs - , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } - - -- Constructing the edges for the main Rec computation - -- See Note [Forming Rec groups] - (bndrs, body) = collectBinders rhs - (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body - rhs' = mkLams bndrs' body' - rhs_usage2 = foldr andUDs rhs_usage1 rule_uds - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - rhs_usage3 = case mb_unf_uds of - Just unf_uds -> rhs_usage2 `andUDs` unf_uds - Nothing -> rhs_usage2 - node_fvs = udFreeVars bndr_set rhs_usage3 - - -- Finding the free variables of the rules - is_active = occ_rule_act env :: Activation -> Bool - - rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr - - rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs - rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) - (lookupVarEnv imp_rule_edges bndr) - -- See Note [Preventing loops due to imported functions rules] - [ (ru_act rule, udFreeVars bndr_set rhs_uds) - | (rule, _, rhs_uds) <- rules_w_uds ] - rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds - active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs - , is_active a] - - -- Finding the usage details of the INLINE pragma (if any) - mb_unf_uds = occAnalUnfolding env Recursive bndr - - -- Find the "nd_inl" free vars; for the loop-breaker phase - inl_fvs = case mb_unf_uds of - Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS - Just unf_uds -> udFreeVars bndr_set unf_uds - -- We could check for an *active* INLINE (returning - -- emptyVarSet for an inactive one), but is_active - -- isn't the right thing (it tells about - -- RULE activation), so we'd need more plumbing - -mkLoopBreakerNodes :: OccEnv -> TopLevelFlag - -> VarSet - -> UsageDetails -- for BODY of let - -> [Details] - -> (UsageDetails, -- adjusted - [LetrecNode]) --- Does four things --- a) tag each binder with its occurrence info --- b) add a NodeScore to each node --- c) make a Node with the right dependency edges for --- the loop-breaker SCC analysis --- d) adjust each RHS's usage details according to --- the binder's (new) shotness and join-point-hood -mkLoopBreakerNodes env lvl bndr_set body_uds details_s - = (final_uds, zipWith mk_lb_node details_s bndrs') - where - (final_uds, bndrs') = tagRecBinders lvl body_uds - [ ((nd_bndr nd) - ,(nd_uds nd) - ,(nd_rhs_bndrs nd)) - | nd <- details_s ] - mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' - = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps) - -- It's OK to use nonDetKeysUniqSet here as - -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges - -- in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. - where - nd' = nd { nd_bndr = bndr', nd_score = score } - score = nodeScore env bndr bndr' rhs lb_deps - lb_deps = extendFvs_ rule_fv_env inl_fvs - - rule_fv_env :: IdEnv IdSet - -- Maps a variable f to the variables from this group - -- mentioned in RHS of active rules for f - -- Domain is *subset* of bound vars (others have no rule fvs) - rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) - init_rule_fvs -- See Note [Finding rule RHS free vars] - = [ (b, trimmed_rule_fvs) - | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s - , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set - , not (isEmptyVarSet trimmed_rule_fvs) ] - - ------------------------------------------- -nodeScore :: OccEnv - -> Id -- Binder has old occ-info (just for loop-breaker-ness) - -> Id -- Binder with new occ-info - -> CoreExpr -- RHS - -> VarSet -- Loop-breaker dependencies - -> NodeScore -nodeScore env old_bndr new_bndr bind_rhs lb_deps - | not (isId old_bndr) -- A type or coercion variable is never a loop breaker - = (100, 0, False) - - | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers - = (0, 0, True) -- See Note [Self-recursion and loop breakers] - - | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has - = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker - - | exprIsTrivial rhs - = mk_score 10 -- Practically certain to be inlined - -- Used to have also: && not (isExportedId bndr) - -- But I found this sometimes cost an extra iteration when we have - -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } - -- where df is the exported dictionary. Then df makes a really - -- bad choice for loop breaker - - | DFunUnfolding { df_args = args } <- id_unfolding - -- Never choose a DFun as a loop breaker - -- Note [DFuns should not be loop breakers] - = (9, length args, is_lb) - - -- Data structures are more important than INLINE pragmas - -- so that dictionary/method recursion unravels - - | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding - = mk_score 6 - - | is_con_app rhs -- Data types help with cases: - = mk_score 5 -- Note [Constructor applications] - - | isStableUnfolding id_unfolding - , can_unfold - = mk_score 3 - - | isOneOcc (idOccInfo new_bndr) - = mk_score 2 -- Likely to be inlined - - | can_unfold -- The Id has some kind of unfolding - = mk_score 1 - - | otherwise - = (0, 0, is_lb) - - where - mk_score :: Int -> NodeScore - mk_score rank = (rank, rhs_size, is_lb) - - is_lb = isStrongLoopBreaker (idOccInfo old_bndr) - rhs = case id_unfolding of - CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } - | isStableSource src - -> unf_rhs - _ -> bind_rhs - -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding - rhs_size = case id_unfolding of - CoreUnfolding { uf_guidance = guidance } - | UnfIfGoodArgs { ug_size = size } <- guidance - -> size - _ -> cheapExprSize rhs - - can_unfold = canUnfold id_unfolding - id_unfolding = realIdUnfolding old_bndr - -- realIdUnfolding: Ignore loop-breaker-ness here because - -- that is what we are setting! - - -- Checking for a constructor application - -- Cheap and cheerful; the simplifier moves casts out of the way - -- The lambda case is important to spot x = /\a. C (f a) - -- which comes up when C is a dictionary constructor and - -- f is a default method. - -- Example: the instance for Show (ST s a) in GHC.ST - -- - -- However we *also* treat (\x. C p q) as a con-app-like thing, - -- Note [Closure conversion] - is_con_app (Var v) = isConLikeId v - is_con_app (App f _) = is_con_app f - is_con_app (Lam _ e) = is_con_app e - is_con_app (Tick _ e) = is_con_app e - is_con_app _ = False - -maxExprSize :: Int -maxExprSize = 20 -- Rather arbitrary - -cheapExprSize :: CoreExpr -> Int --- Maxes out at maxExprSize -cheapExprSize e - = go 0 e - where - go n e | n >= maxExprSize = n - | otherwise = go1 n e - - go1 n (Var {}) = n+1 - go1 n (Lit {}) = n+1 - go1 n (Type {}) = n - go1 n (Coercion {}) = n - go1 n (Tick _ e) = go1 n e - go1 n (Cast e _) = go1 n e - go1 n (App f a) = go (go1 n f) a - go1 n (Lam b e) - | isTyVar b = go1 n e - | otherwise = go (n+1) e - go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) - go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) - - gos n [] = n - gos n (e:es) | n >= maxExprSize = n - | otherwise = gos (go1 n e) es - -betterLB :: NodeScore -> NodeScore -> Bool --- If n1 `betterLB` n2 then choose n1 as the loop breaker -betterLB (rank1, size1, lb1) (rank2, size2, _) - | rank1 < rank2 = True - | rank1 > rank2 = False - | size1 < size2 = False -- Make the bigger n2 into the loop breaker - | size1 > size2 = True - | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it - | otherwise = False -- See Note [Loop breakers, node scoring, and stability] - -{- Note [Self-recursion and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - rec { f = ...f...g... - ; g = .....f... } -then 'f' has to be a loop breaker anyway, so we may as well choose it -right away, so that g can inline freely. - -This is really just a cheap hack. Consider - rec { f = ...g... - ; g = ..f..h... - ; h = ...f....} -Here f or g are better loop breakers than h; but we might accidentally -choose h. Finding the minimal set of loop breakers is hard. - -Note [Loop breakers, node scoring, and stability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To choose a loop breaker, we give a NodeScore to each node in the SCC, -and pick the one with the best score (according to 'betterLB'). - -We need to be jolly careful (#12425, #12234) about the stability -of this choice. Suppose we have - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...f.. - False -> ..f... - -In each iteration of the simplifier the occurrence analyser OccAnal -chooses a loop breaker. Suppose in iteration 1 it choose g as the loop -breaker. That means it is free to inline f. - -Suppose that GHC decides to inline f in the branches of the case, but -(for some reason; eg it is not saturated) in the rhs of g. So we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...g...g..... - False -> ..g..g.... - -Now suppose that, for some reason, in the next iteration the occurrence -analyser chooses f as the loop breaker, so it can freely inline g. And -again for some reason the simplifier inlines g at its calls in the case -branches, but not in the RHS of f. Then we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...(...f...f...)...(...f..f..)..... - False -> ..(...f...f...)...(..f..f...).... - -You can see where this is going! Each iteration of the simplifier -doubles the number of calls to f or g. No wonder GHC is slow! - -(In the particular example in comment:3 of #12425, f and g are the two -mutually recursive fmap instances for CondT and Result. They are both -marked INLINE which, oddly, is why they don't inline in each other's -RHS, because the call there is not saturated.) - -The root cause is that we flip-flop on our choice of loop breaker. I -always thought it didn't matter, and indeed for any single iteration -to terminate, it doesn't matter. But when we iterate, it matters a -lot!! - -So The Plan is this: - If there is a tie, choose the node that - was a loop breaker last time round - -Hence the is_lb field of NodeScore - -************************************************************************ -* * - Right hand sides -* * -************************************************************************ --} - -occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRhs env Recursive _ bndrs body - = occAnalRecRhs env bndrs body -occAnalRhs env NonRecursive id bndrs body - = occAnalNonRecRhs env id bndrs body - -occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body - -occAnalNonRecRhs :: OccEnv - -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body - -- Binder is already tagged with occurrence info - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalNonRecRhs env bndr bndrs body - = occAnalLamOrRhs rhs_env bndrs body - where - env1 | is_join_point = env -- See Note [Join point RHSs] - | certainly_inline = env -- See Note [Cascading inlines] - | otherwise = rhsCtxt env - - -- See Note [Sources of one-shot information] - rhs_env = env1 { occ_one_shots = argOneShots dmd } - - certainly_inline -- See Note [Cascading inlines] - = case occ of - OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch } - -> active && not_stable - _ -> False - - is_join_point = isAlwaysTailCalled occ - -- Like (isJoinId bndr) but happens one step earlier - -- c.f. willBeJoinId_maybe - - occ = idOccInfo bndr - dmd = idDemandInfo bndr - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) - -occAnalUnfolding :: OccEnv - -> RecFlag - -> Id - -> Maybe UsageDetails - -- Just the analysis, not a new unfolding. The unfolding - -- got analysed when it was created and we don't need to - -- update it. -occAnalUnfolding env rec_flag id - = case realIdUnfolding id of -- ignore previous loop-breaker flag - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | not (isStableSource src) - -> Nothing - | otherwise - -> Just $ markAllMany usage - where - (bndrs, body) = collectBinders rhs - (usage, _, _) = occAnalRhs env rec_flag id bndrs body - - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just $ zapDetails (delDetailsList usage bndrs) - where - usage = andUDsList (map (fst . occAnal env) args) - - _ -> Nothing - -occAnalRules :: OccEnv - -> Maybe JoinArity -- If the binder is (or MAY become) a join - -- point, what its join arity is (or WOULD - -- become). See Note [Rules and join points]. - -> RecFlag - -> Id - -> [(CoreRule, -- Each (non-built-in) rule - UsageDetails, -- Usage details for LHS - UsageDetails)] -- Usage details for RHS -occAnalRules env mb_expected_join_arity rec_flag id - = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id - , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] - where - occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = (lhs_uds, final_rhs_uds) - where - lhs_uds = addManyOccsSet emptyDetails $ - (exprsFreeVars args `delVarSetList` bndrs) - (rhs_bndrs, rhs_body) = collectBinders rhs - (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - final_rhs_uds = adjust_tail_info args $ markAllMany $ - (rhs_uds `delDetailsList` bndrs) - occ_anal_rule _ - = (emptyDetails, emptyDetails) - - adjust_tail_info args uds -- see Note [Rules and join points] - = case mb_expected_join_arity of - Just ar | args `lengthIs` ar -> uds - _ -> markAllNonTailCalled uds -{- Note [Join point RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = e - join j = Just x - -We want to inline x into j right away, so we don't want to give -the join point a RhsCtxt (#14137). It's not a huge deal, because -the FloatIn pass knows to float into join point RHSs; and the simplifier -does not float things out of join point RHSs. But it's a simple, cheap -thing to do. See #14137. - -Note [Cascading inlines] -~~~~~~~~~~~~~~~~~~~~~~~~ -By default we use an rhsCtxt for the RHS of a binding. This tells the -occ anal n that it's looking at an RHS, which has an effect in -occAnalApp. In particular, for constructor applications, it makes -the arguments appear to have NoOccInfo, so that we don't inline into -them. Thus x = f y - k = Just x -we do not want to inline x. - -But there's a problem. Consider - x1 = a0 : [] - x2 = a1 : x1 - x3 = a2 : x2 - g = f x3 -First time round, it looks as if x1 and x2 occur as an arg of a -let-bound constructor ==> give them a many-occurrence. -But then x3 is inlined (unconditionally as it happens) and -next time round, x2 will be, and the next time round x1 will be -Result: multiple simplifier iterations. Sigh. - -So, when analysing the RHS of x3 we notice that x3 will itself -definitely inline the next time round, and so we analyse x3's rhs in -an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. - -Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally. -If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and - (b) certainly_inline says "yes" when preInlineUnconditionally says "no" -then the simplifier iterates indefinitely: - x = f y - k = Just x -- We decide that k is 'certainly_inline' - v = ...k... -- but preInlineUnconditionally doesn't inline it -inline ==> - k = Just (f y) - v = ...k... -float ==> - x1 = f y - k = Just x1 - v = ...k... - -This is worse than the slow cascade, so we only want to say "certainly_inline" -if it really is certain. Look at the note with preInlineUnconditionally -for the various clauses. - - -************************************************************************ -* * - Expressions -* * -************************************************************************ --} - -occAnal :: OccEnv - -> CoreExpr - -> (UsageDetails, -- Gives info only about the "interesting" Ids - CoreExpr) - -occAnal _ expr@(Type _) = (emptyDetails, expr) -occAnal _ expr@(Lit _) = (emptyDetails, expr) -occAnal env expr@(Var _) = occAnalApp env (expr, [], []) - -- At one stage, I gathered the idRuleVars for the variable here too, - -- which in a way is the right thing to do. - -- But that went wrong right after specialisation, when - -- the *occurrences* of the overloaded function didn't have any - -- rules in them, so the *specialised* versions looked as if they - -- weren't used at all. - -occAnal _ (Coercion co) - = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) - -- See Note [Gather occurrences of coercion variables] - -{- -Note [Gather occurrences of coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to gather info about what coercion variables appear, so that -we can sort them into the right place when doing dependency analysis. --} - -occAnal env (Tick tickish body) - | SourceNote{} <- tickish - = (usage, Tick tickish body') - -- SourceNotes are best-effort; so we just proceed as usual. - -- If we drop a tick due to the issues described below it's - -- not the end of the world. - - | tickish `tickishScopesLike` SoftScope - = (markAllNonTailCalled usage, Tick tickish body') - - | Breakpoint _ ids <- tickish - = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') - -- never substitute for any of the Ids in a Breakpoint - - | otherwise - = (usage_lam, Tick tickish body') - where - !(usage,body') = occAnal env body - -- for a non-soft tick scope, we can inline lambdas only - usage_lam = markAllNonTailCalled (markAllInsideLam usage) - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -- See #14242. - -occAnal env (Cast expr co) - = case occAnal env expr of { (usage, expr') -> - let usage1 = zapDetailsIf (isRhsEnv env) usage - -- usage1: if we see let x = y `cast` co - -- then mark y as 'Many' so that we don't - -- immediately inline y again. - usage2 = addManyOccsSet usage1 (coVarsOfCo co) - -- usage2: see Note [Gather occurrences of coercion variables] - in (markAllNonTailCalled usage2, Cast expr' co) - } - -occAnal env app@(App _ _) - = occAnalApp env (collectArgsTicks tickishFloatable app) - --- Ignore type variables altogether --- (a) occurrences inside type lambdas only not marked as InsideLam --- (b) type variables not in environment - -occAnal env (Lam x body) - | isTyVar x - = case occAnal env body of { (body_usage, body') -> - (markAllNonTailCalled body_usage, Lam x body') - } - --- For value lambdas we do a special hack. Consider --- (\x. \y. ...x...) --- If we did nothing, x is used inside the \y, so would be marked --- as dangerous to dup. But in the common case where the abstraction --- is applied to two arguments this is over-pessimistic. --- So instead, we just mark each binder with its occurrence --- info in the *body* of the multiple lambda. --- Then, the simplifier is careful when partially applying lambdas. - -occAnal env expr@(Lam _ _) - = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> - let - expr' = mkLams tagged_binders body' - usage1 = markAllNonTailCalled usage - one_shot_gp = all isOneShotBndr tagged_binders - final_usage | one_shot_gp = usage1 - | otherwise = markAllInsideLam usage1 - in - (final_usage, expr') } - where - (binders, body) = collectBinders expr - -occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> - let - alts_usage = foldr orUDs emptyDetails alts_usage_s - (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr - total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1 - -- Alts can have tail calls, but the scrutinee can't - in - total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} - where - alt_env = mkAltEnv env scrut bndr - occ_anal_alt = occAnalAlt alt_env - - occ_anal_scrut (Var v) (alt1 : other_alts) - | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v IsInteresting 0, Var v) - -- The 'True' says that the variable occurs in an interesting - -- context; the case has at least one non-default alternative - occ_anal_scrut (Tick t e) alts - | t `tickishScopesLike` SoftScope - -- No reason to not look through all ticks here, but only - -- for soft-scoped ticks we can do so without having to - -- update returned occurrence info (see occAnal) - = second (Tick t) $ occ_anal_scrut e alts - - occ_anal_scrut scrut _alts - = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt - -occAnal env (Let bind body) - = case occAnal env body of { (body_usage, body') -> - case occAnalBind env NotTopLevel - noImpRuleEdges bind - body_usage of { (final_usage, new_binds) -> - (final_usage, mkLets new_binds body') }} - -occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) -occAnalArgs _ [] _ - = (emptyDetails, []) - -occAnalArgs env (arg:args) one_shots - | isTypeArg arg - = case occAnalArgs env args one_shots of { (uds, args') -> - (uds, arg:args') } - - | otherwise - = case argCtxt env one_shots of { (arg_env, one_shots') -> - case occAnal arg_env arg of { (uds1, arg') -> - case occAnalArgs env args one_shots' of { (uds2, args') -> - (uds1 `andUDs` uds2, arg':args') }}} - -{- -Applications are dealt with specially because we want -the "build hack" to work. - -Note [Arguments of let-bound constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. - -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. --} - -occAnalApp :: OccEnv - -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) - -> (UsageDetails, Expr CoreBndr) -occAnalApp env (Var fun, args, ticks) - | null ticks = (uds, mkApps (Var fun) args') - | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') - where - uds = fun_uds `andUDs` final_args_uds - - !(args_uds, args') = occAnalArgs env args one_shots - !final_args_uds - | isRhsEnv env && is_exp = markAllNonTailCalled $ - markAllInsideLam args_uds - | otherwise = markAllNonTailCalled args_uds - -- We mark the free vars of the argument of a constructor or PAP - -- as "inside-lambda", if it is the RHS of a let(rec). - -- This means that nothing gets inlined into a constructor or PAP - -- argument position, which is what we want. Typically those - -- constructor arguments are just variables, or trivial expressions. - -- We use inside-lam because it's like eta-expanding the PAP. - -- - -- This is the *whole point* of the isRhsEnv predicate - -- See Note [Arguments of let-bound constructors] - - n_val_args = valArgCount args - n_args = length args - fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args - is_exp = isExpandableApp fun n_val_args - -- See Note [CONLIKE pragma] in BasicTypes - -- The definition of is_exp should match that in Simplify.prepareRhs - - one_shots = argsOneShots (idStrictness fun) guaranteed_val_args - guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo - (occ_one_shots env)) - -- See Note [Sources of one-shot information], bullet point A'] - -occAnalApp env (fun, args, ticks) - = (markAllNonTailCalled (fun_uds `andUDs` args_uds), - mkTicks ticks $ mkApps fun' args') - where - !(fun_uds, fun') = occAnal (addAppCtxt env args) fun - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexs like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some True items - -- onto the context stack. - !(args_uds, args') = occAnalArgs env args [] - -zapDetailsIf :: Bool -- If this is true - -> UsageDetails -- Then do zapDetails on this - -> UsageDetails -zapDetailsIf True uds = zapDetails uds -zapDetailsIf False uds = uds - -{- -Note [Sources of one-shot information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The occurrence analyser obtains one-shot-lambda information from two sources: - -A: Saturated applications: eg f e1 .. en - - In general, given a call (f e1 .. en) we can propagate one-shot info from - f's strictness signature into e1 .. en, but /only/ if n is enough to - saturate the strictness signature. A strictness signature like - - f :: C1(C1(L))LS - - means that *if f is applied to three arguments* then it will guarantee to - call its first argument at most once, and to call the result of that at - most once. But if f has fewer than three arguments, all bets are off; e.g. - - map (f (\x y. expensive) e2) xs - - Here the \x y abstraction may be called many times (once for each element of - xs) so we should not mark x and y as one-shot. But if it was - - map (f (\x y. expensive) 3 2) xs - - then the first argument of f will be called at most once. - - The one-shot info, derived from f's strictness signature, is - computed by 'argsOneShots', called in occAnalApp. - -A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) - where f is as above. - - In this case, f is only manifestly applied to one argument, so it does not - look saturated. So by the previous point, we should not use its strictness - signature to learn about the one-shotness of \x y. But in this case we can: - build is fully applied, so we may use its strictness signature; and from - that we learn that build calls its argument with two arguments *at most once*. - - So there is really only one call to f, and it will have three arguments. In - that sense, f is saturated, and we may proceed as described above. - - Hence the computation of 'guaranteed_val_args' in occAnalApp, using - '(occ_one_shots env)'. See also #13227, comment:9 - -B: Let-bindings: eg let f = \c. let ... in \n -> blah - in (build f, build f) - - Propagate one-shot info from the demanand-info on 'f' to the - lambdas in its RHS (which may not be syntactically at the top) - - This information must have come from a previous run of the demanand - analyser. - -Previously, the demand analyser would *also* set the one-shot information, but -that code was buggy (see #11770), so doing it only in on place, namely here, is -saner. - -Note [OneShots] -~~~~~~~~~~~~~~~ -When analysing an expression, the occ_one_shots argument contains information -about how the function is being used. The length of the list indicates -how many arguments will eventually be passed to the analysed expression, -and the OneShotInfo indicates whether this application is once or multiple times. - -Example: - - Context of f occ_one_shots when analysing f - - f 1 2 [OneShot, OneShot] - map (f 1) [OneShot, NoOneShotInfo] - build f [OneShot, OneShot] - f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] - -Note [Binders in case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case x of y { (a,b) -> f y } -We treat 'a', 'b' as dead, because they don't physically occur in the -case alternative. (Indeed, a variable is dead iff it doesn't occur in -its scope in the output of OccAnal.) It really helps to know when -binders are unused. See esp the call to isDeadBinder in -Simplify.mkDupableAlt - -In this example, though, the Simplifier will bring 'a' and 'b' back to -life, because it binds 'y' to (a,b) (imagine got inlined and -scrutinised y). --} - -occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) -occAnalLamOrRhs env [] body - = case occAnal env body of (body_usage, body') -> (body_usage, [], body') - -- RHS of thunk or nullary join point -occAnalLamOrRhs env (bndr:bndrs) body - | isTyVar bndr - = -- Important: Keep the environment so that we don't inline into an RHS like - -- \(@ x) -> C @x (f @x) - -- (see the beginning of Note [Cascading inlines]). - case occAnalLamOrRhs env bndrs body of - (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') -occAnalLamOrRhs env binders body - = case occAnal env_body body of { (body_usage, body') -> - let - (final_usage, tagged_binders) = tagLamBinders body_usage binders' - -- Use binders' to put one-shot info on the lambdas - in - (final_usage, tagged_binders, body') } - where - (env_body, binders') = oneShotGroup env binders - -occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) - -> CoreAlt - -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt (env, scrut_bind) (con, bndrs, rhs) - = case occAnal env rhs of { (rhs_usage1, rhs1) -> - let - (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs - -- See Note [Binders in case alternatives] - (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 - in - (alt_usg', (con, tagged_bndrs, rhs2)) } - -wrapAltRHS :: OccEnv - -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv - -> UsageDetails -- usage for entire alt (p -> rhs) - -> [Var] -- alt binders - -> CoreExpr -- alt RHS - -> (UsageDetails, CoreExpr) -wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs - | occ_binder_swap env - , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this - -- handles condition (a) in Note [Binder swap] - , not captured -- See condition (b) in Note [Binder swap] - = ( alt_usg' `andUDs` let_rhs_usg - , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) - where - captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) - - -- The rhs of the let may include coercion variables - -- if the scrutinee was a cast, so we must gather their - -- usage. See Note [Gather occurrences of coercion variables] - -- Moreover, the rhs of the let may mention the case-binder, and - -- we want to gather its occ-info as well - (let_rhs_usg, let_rhs') = occAnal env let_rhs - - (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var - -wrapAltRHS _ _ alt_usg _ alt_rhs - = (alt_usg, alt_rhs) - -{- -************************************************************************ -* * - OccEnv -* * -************************************************************************ --} - -data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_gbl_scrut :: GlobalScruts - - , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active - - , occ_rule_act :: Activation -> Bool -- Which rules are active - -- See Note [Finding rule RHS free vars] - - , occ_binder_swap :: !Bool -- enable the binder_swap - -- See CorePrep Note [Dead code in CorePrep] - } - -type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] - ------------------------------ --- OccEncl is used to control whether to inline into constructor arguments --- For example: --- x = (p,q) -- Don't inline p or q --- y = /\a -> (p a, q a) -- Still don't inline p or q --- z = f (p,q) -- Do inline p,q; it may make a rule fire --- So OccEncl tells enough about the context to know what to do when --- we encounter a constructor application or PAP. - -data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. - -- Do inline into constructor args here - -instance Outputable OccEncl where - ppr OccRhs = text "occRhs" - ppr OccVanilla = text "occVanilla" - --- See note [OneShots] -type OneShots = [OneShotInfo] - -initOccEnv :: OccEnv -initOccEnv - = OccEnv { occ_encl = OccVanilla - , occ_one_shots = [] - , occ_gbl_scrut = emptyVarSet - -- To be conservative, we say that all - -- inlines and rules are active - , occ_unf_act = \_ -> True - , occ_rule_act = \_ -> True - , occ_binder_swap = True } - -vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } - -rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } - -argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) -argCtxt env [] - = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) -argCtxt env (one_shots:one_shots_s) - = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) - -isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv { occ_encl = OccRhs }) = True -isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False - -oneShotGroup :: OccEnv -> [CoreBndr] - -> ( OccEnv - , [CoreBndr] ) - -- The result binders have one-shot-ness set that they might not have had originally. - -- This happens in (build (\c n -> e)). Here the occurrence analyser - -- linearity context knows that c,n are one-shot, and it records that fact in - -- the binder. This is useful to guide subsequent float-in/float-out transformations - -oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs - = go ctxt bndrs [] - where - go ctxt [] rev_bndrs - = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } - , reverse rev_bndrs ) - - go [] bndrs rev_bndrs - = ( env { occ_one_shots = [], occ_encl = OccVanilla } - , reverse rev_bndrs ++ bndrs ) - - go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs - | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) - | otherwise = go ctxt bndrs (bndr : rev_bndrs) - where - bndr' = updOneShotInfo bndr one_shot - -- Use updOneShotInfo, not setOneShotInfo, as pre-existing - -- one-shot info might be better than what we can infer, e.g. - -- due to explicit use of the magic 'oneShot' function. - -- See Note [The oneShot function] - - -markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] --- Mark the lambdas of a non-recursive join point as one-shot. --- This is good to prevent gratuitous float-out etc -markJoinOneShots mb_join_arity bndrs - = case mb_join_arity of - Nothing -> bndrs - Just n -> go n bndrs - where - go 0 bndrs = bndrs - go _ [] = [] -- This can legitimately happen. - -- e.g. let j = case ... in j True - -- This will become an arity-1 join point after the - -- simplifier has eta-expanded it; but it may not have - -- enough lambdas /yet/. (Lint checks that JoinIds do - -- have enough lambdas.) - go n (b:bs) = b' : go (n-1) bs - where - b' | isId b = setOneShotLambda b - | otherwise = b - -addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args - = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } - -transClosureFV :: UniqFM VarSet -> UniqFM VarSet --- If (f,g), (g,h) are in the input, then (f,h) is in the output --- as well as (f,g), (g,h) -transClosureFV env - | no_change = env - | otherwise = transClosureFV (listToUFM new_fv_list) - where - (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) - -- It's OK to use nonDetUFMToList here because we'll forget the - -- ordering by creating a new set with listToUFM - bump no_change (b,fvs) - | no_change_here = (no_change, (b,fvs)) - | otherwise = (False, (b,new_fvs)) - where - (new_fvs, no_change_here) = extendFvs env fvs - -------------- -extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet -extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag - -extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) --- (extendFVs env s) returns --- (s `union` env(s), env(s) `subset` s) -extendFvs env s - | isNullUFM env - = (s, True) - | otherwise - = (s `unionVarSet` extras, extras `subVarSet` s) - where - extras :: VarSet -- env(s) - extras = nonDetFoldUFM unionVarSet emptyVarSet $ - -- It's OK to use nonDetFoldUFM here because unionVarSet commutes - intersectUFM_C (\x _ -> x) env (getUniqSet s) - -{- -************************************************************************ -* * - Binder swap -* * -************************************************************************ - -Note [Binder swap] -~~~~~~~~~~~~~~~~~~ -The "binder swap" transformation swaps occurrence of the -scrutinee of a case for occurrences of the case-binder: - - (1) case x of b { pi -> ri } - ==> - case x of b { pi -> let x=b in ri } - - (2) case (x |> co) of b { pi -> ri } - ==> - case (x |> co) of b { pi -> let x = b |> sym co in ri } - -In both cases, the trivial 'let' can be eliminated by the -immediately following simplifier pass. - -There are two reasons for making this swap: - -(A) It reduces the number of occurrences of the scrutinee, x. - That in turn might reduce its occurrences to one, so we - can inline it and save an allocation. E.g. - let x = factorial y in case x of b { I# v -> ...x... } - If we replace 'x' by 'b' in the alternative we get - let x = factorial y in case x of b { I# v -> ...b... } - and now we can inline 'x', thus - case (factorial y) of b { I# v -> ...b... } - -(B) The case-binder b has unfolding information; in the - example above we know that b = I# v. That in turn allows - nested cases to simplify. Consider - case x of b { I# v -> - ...(case x of b2 { I# v2 -> rhs })... - If we replace 'x' by 'b' in the alternative we get - case x of b { I# v -> - ...(case b of b2 { I# v2 -> rhs })... - and now it is trivial to simplify the inner case: - case x of b { I# v -> - ...(let b2 = b in rhs)... - - The same can happen even if the scrutinee is a variable - with a cast: see Note [Case of cast] - -In both cases, in a particular alternative (pi -> ri), we only -add the binding if - (a) x occurs free in (pi -> ri) - (ie it occurs in ri, but is not bound in pi) - (b) the pi does not bind b (or the free vars of co) -We need (a) and (b) for the inserted binding to be correct. - -For the alternatives where we inject the binding, we can transfer -all x's OccInfo to b. And that is the point. - -Notice that - * The deliberate shadowing of 'x'. - * That (a) rapidly becomes false, so no bindings are injected. - -The reason for doing these transformations /here in the occurrence -analyser/ is because it allows us to adjust the OccInfo for 'x' and -'b' as we go. - - * Suppose the only occurrences of 'x' are the scrutinee and in the - ri; then this transformation makes it occur just once, and hence - get inlined right away. - - * If instead we do this in the Simplifier, we don't know whether 'x' - is used in ri, so we are forced to pessimistically zap b's OccInfo - even though it is typically dead (ie neither it nor x appear in - the ri). There's nothing actually wrong with zapping it, except - that it's kind of nice to know which variables are dead. My nose - tells me to keep this information as robustly as possible. - -The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding -{x=b}; it's Nothing if the binder-swap doesn't happen. - -There is a danger though. Consider - let v = x +# y - in case (f v) of w -> ...v...v... -And suppose that (f v) expands to just v. Then we'd like to -use 'w' instead of 'v' in the alternative. But it may be too -late; we may have substituted the (cheap) x+#y for v in the -same simplifier pass that reduced (f v) to v. - -I think this is just too bad. CSE will recover some of it. - -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (x `cast` co) of b { I# -> - ... (case (x `cast` co) of {...}) ... -We'd like to eliminate the inner case. That is the motivation for -equation (2) in Note [Binder swap]. When we get to the inner case, we -inline x, cancel the casts, and away we go. - -Note [Binder swap on GlobalId scrutinees] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the scrutinee is a GlobalId we must take care in two ways - - i) In order to *know* whether 'x' occurs free in the RHS, we need its - occurrence info. BUT, we don't gather occurrence info for - GlobalIds. That's the reason for the (small) occ_gbl_scrut env in - OccEnv is for: it says "gather occurrence info for these". - - ii) We must call localiseId on 'x' first, in case it's a GlobalId, or - has an External Name. See, for example, SimplEnv Note [Global Ids in - the substitution]. - -Note [Zap case binders in proxy bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From the original - case x of cb(dead) { p -> ...x... } -we will get - case x of cb(live) { p -> let x = cb in ...x... } - -Core Lint never expects to find an *occurrence* of an Id marked -as Dead, so we must zap the OccInfo on cb before making the -binding x = cb. See #5028. - -NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier -doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. - -Historical note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressions when --fno-case-of-case is on. Old remarks: - "This happens in the first simplifier pass, - and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) - If we eliminate the inner case, we trap it inside the I# v -> arm, - which might prevent some full laziness happening. I've seen this - in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] - Hence the check for NoCaseOfCase." -However, now the full-laziness pass itself reverses the binder-swap, so this -check is no longer necessary. - -Historical note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This old note describes a problem that is also fixed by doing the -binder-swap in OccAnal: - - There is another situation when it might make sense to suppress the - case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - - We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - - But there is no point in doing it for the inner case, because w1 can't - be inlined anyway. Furthermore, doing the case-swapping involves - zapping w2's occurrence info (see paragraphs that follow), and that - forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - - This is plain silly in the common case where w2 is dead. - - Even so, I can't see a good way to implement this idea. I tried - not doing the binder-swap if the scrutinee was already evaluated - but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - - Notice that because MkT is strict, x is marked "evaluated". But to - eliminate the last case, we must either make sure that x (as well as - x1) has unfolding MkT y1. The straightforward thing to do is to do - the binder-swap. So this whole note is a no-op. - -It's fixed by doing the binder-swap in OccAnal because we can do the -binder-swap unconditionally and still get occurrence analysis -information right. --} - -mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does three things: a) makes the occ_one_shots = OccVanilla --- b) extends the GlobalScruts if possible --- c) returns a proxy mapping, binding the scrutinee --- to the case binder, if possible -mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr - = case stripTicksTopE (const True) scrut of - Var v -> add_scrut v case_bndr' - Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) - -- See Note [Case of cast] - _ -> (env { occ_encl = OccVanilla }, Nothing) - - where - add_scrut v rhs - | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing) - | otherwise = ( env { occ_encl = OccVanilla - , occ_gbl_scrut = pe `extendVarSet` v } - , Just (localise v, rhs) ) - -- ToDO: this isGlobalId stuff is a TEMPORARY FIX - -- to avoid the binder-swap for GlobalIds - -- See #16346 - - case_bndr' = Var (zapIdOccInfo case_bndr) - -- See Note [Zap case binders in proxy bindings] - - -- Localise the scrut_var before shadowing it; we're making a - -- new binding for it, and it might have an External Name, or - -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLINE or NOINLINE pragmas! - localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) - (idType scrut_var) - -{- -************************************************************************ -* * -\subsection[OccurAnal-types]{OccEnv} -* * -************************************************************************ - -Note [UsageDetails and zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -On many occasions, we must modify all gathered occurrence data at once. For -instance, all occurrences underneath a (non-one-shot) lambda set the -'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but -that takes O(n) time and we will do this often---in particular, there are many -places where tail calls are not allowed, and each of these causes all variables -to get marked with 'NoTailCallInfo'. - -Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along -with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" -recording which variables have been zapped in some way. Zapping all occurrence -info then simply means setting the corresponding zapped set to the whole -'OccInfoEnv', a fast O(1) operation. --} - -type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage - -- INVARIANT: never IAmDead - -- (Deadness is signalled by not being in the map at all) - -type ZappedSet = OccInfoEnv -- Values are ignored - -data UsageDetails - = UD { ud_env :: !OccInfoEnv - , ud_z_many :: ZappedSet -- apply 'markMany' to these - , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these - , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these - -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv - -instance Outputable UsageDetails where - ppr ud = ppr (ud_env (flattenUsageDetails ud)) - -------------------- --- UsageDetails API - -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails -andUDs = combineUsageDetailsWith addOccInfo -orUDs = combineUsageDetailsWith orOccInfo - -andUDsList :: [UsageDetails] -> UsageDetails -andUDsList = foldl' andUDs emptyDetails - -mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails -mkOneOcc env id int_cxt arity - | isLocalId id - = singleton $ OneOcc { occ_in_lam = NotInsideLam - , occ_one_br = InOneBranch - , occ_int_cxt = int_cxt - , occ_tail = AlwaysTailCalled arity } - | id `elemVarSet` occ_gbl_scrut env - = singleton noOccInfo - - | otherwise - = emptyDetails - where - singleton info = emptyDetails { ud_env = unitVarEnv id info } - -addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails -addOneOcc ud id info - = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } - `alterZappedSets` (`delVarEnv` id) - where - plus_zapped old new = doZapping ud id old `addOccInfo` new - -addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails -addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set - -- It's OK to use nonDetFoldUFM here because addManyOccs commutes - --- Add several occurrences, assumed not to be tail calls -addManyOccs :: Var -> UsageDetails -> UsageDetails -addManyOccs v u | isId v = addOneOcc u v noOccInfo - | otherwise = u - -- Give a non-committal binder info (i.e noOccInfo) because - -- a) Many copies of the specialised thing can appear - -- b) We don't want to substitute a BIG expression inside a RULE - -- even if that's the only occurrence of the thing - -- (Same goes for INLINE.) - -delDetails :: UsageDetails -> Id -> UsageDetails -delDetails ud bndr - = ud `alterUsageDetails` (`delVarEnv` bndr) - -delDetailsList :: UsageDetails -> [Id] -> UsageDetails -delDetailsList ud bndrs - = ud `alterUsageDetails` (`delVarEnvList` bndrs) - -emptyDetails :: UsageDetails -emptyDetails = UD { ud_env = emptyVarEnv - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_no_tail = emptyVarEnv } - -isEmptyDetails :: UsageDetails -> Bool -isEmptyDetails = isEmptyVarEnv . ud_env - -markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails - :: UsageDetails -> UsageDetails -markAllMany ud = ud { ud_z_many = ud_env ud } -markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } -markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } - -zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo - -lookupDetails :: UsageDetails -> Id -> OccInfo -lookupDetails ud id - | isCoVar id -- We do not currently gather occurrence info (from types) - = noOccInfo -- for CoVars, so we must conservatively mark them as used - -- See Note [DoO not mark CoVars as dead] - | otherwise - = case lookupVarEnv (ud_env ud) id of - Just occ -> doZapping ud id occ - Nothing -> IAmDead - -usedIn :: Id -> UsageDetails -> Bool -v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud - -udFreeVars :: VarSet -> UsageDetails -> VarSet --- Find the subset of bndrs that are mentioned in uds -udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) - -{- Note [Do not mark CoVars as dead] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's obviously wrong to mark CoVars as dead if they are used. -Currently we don't traverse types to gather usase info for CoVars, -so we had better treat them as having noOccInfo. - -This showed up in #15696 we had something like - case eq_sel d of co -> ...(typeError @(...co...) "urk")... - -Then 'd' was substituted by a dictionary, so the expression -simpified to - case (Coercion ) of co -> ...(typeError @(...co...) "urk")... - -But then the "drop the case altogether" equation of rebuildCase -thought that 'co' was dead, and discarded the entire case. Urk! - -I have no idea how we managed to avoid this pitfall for so long! --} - -------------------- --- Auxiliary functions for UsageDetails implementation - -combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) - -> UsageDetails -> UsageDetails -> UsageDetails -combineUsageDetailsWith plus_occ_info ud1 ud2 - | isEmptyDetails ud1 = ud2 - | isEmptyDetails ud2 = ud1 - | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) - , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) - , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) - , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } - -doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo -doZapping ud var occ - = doZappingByUnique ud (varUnique var) occ - -doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo -doZappingByUnique ud uniq - = (if | in_subset ud_z_many -> markMany - | in_subset ud_z_in_lam -> markInsideLam - | otherwise -> id) . - (if | in_subset ud_z_no_tail -> markNonTailCalled - | otherwise -> id) - where - in_subset field = uniq `elemVarEnvByKey` field ud - -alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails -alterZappedSets ud f - = ud { ud_z_many = f (ud_z_many ud) - , ud_z_in_lam = f (ud_z_in_lam ud) - , ud_z_no_tail = f (ud_z_no_tail ud) } - -alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails -alterUsageDetails ud f - = ud { ud_env = f (ud_env ud) } - `alterZappedSets` f - -flattenUsageDetails :: UsageDetails -> UsageDetails -flattenUsageDetails ud - = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } - `alterZappedSets` const emptyVarEnv - -------------------- --- See Note [Adjusting right-hand sides] -adjustRhsUsage :: Maybe JoinArity -> RecFlag - -> [CoreBndr] -- Outer lambdas, AFTER occ anal - -> UsageDetails -> UsageDetails -adjustRhsUsage mb_join_arity rec_flag bndrs usage - = maybe_mark_lam (maybe_drop_tails usage) - where - maybe_mark_lam ud | one_shot = ud - | otherwise = markAllInsideLam ud - maybe_drop_tails ud | exact_join = ud - | otherwise = markAllNonTailCalled ud - - one_shot = case mb_join_arity of - Just join_arity - | isRec rec_flag -> False - | otherwise -> all isOneShotBndr (drop join_arity bndrs) - Nothing -> all isOneShotBndr bndrs - - exact_join = case mb_join_arity of - Just join_arity -> bndrs `lengthIs` join_arity - _ -> False - -type IdWithOccInfo = Id - -tagLamBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders -tagLamBinders usage binders - = usage' `seq` (usage', bndrs') - where - (usage', bndrs') = mapAccumR tagLamBinder usage binders - -tagLamBinder :: UsageDetails -- Of scope - -> Id -- Binder - -> (UsageDetails, -- Details with binder removed - IdWithOccInfo) -- Tagged binders --- Used for lambda and case binders --- It copes with the fact that lambda bindings can have a --- stable unfolding, used for join points -tagLamBinder usage bndr - = (usage2, bndr') - where - occ = lookupDetails usage bndr - bndr' = setBinderOcc (markNonTailCalled occ) bndr - -- Don't try to make an argument into a join point - usage1 = usage `delDetails` bndr - usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) - -- This is effectively the RHS of a - -- non-join-point binding, so it's okay to use - -- addManyOccsSet, which assumes no tail calls - | otherwise = usage1 - -tagNonRecBinder :: TopLevelFlag -- At top level? - -> UsageDetails -- Of scope - -> CoreBndr -- Binder - -> (UsageDetails, -- Details with binder removed - IdWithOccInfo) -- Tagged binder - -tagNonRecBinder lvl usage binder - = let - occ = lookupDetails usage binder - will_be_join = decideJoinPointHood lvl usage [binder] - occ' | will_be_join = -- must already be marked AlwaysTailCalled - ASSERT(isAlwaysTailCalled occ) occ - | otherwise = markNonTailCalled occ - binder' = setBinderOcc occ' binder - usage' = usage `delDetails` binder - in - usage' `seq` (usage', binder') - -tagRecBinders :: TopLevelFlag -- At top level? - -> UsageDetails -- Of body of let ONLY - -> [(CoreBndr, -- Binder - UsageDetails, -- RHS usage details - [CoreBndr])] -- Lambdas in new RHS - -> (UsageDetails, -- Adjusted details for whole scope, - -- with binders removed - [IdWithOccInfo]) -- Tagged binders --- Substantially more complicated than non-recursive case. Need to adjust RHS --- details *before* tagging binders (because the tags depend on the RHSes). -tagRecBinders lvl body_uds triples - = let - (bndrs, rhs_udss, _) = unzip3 triples - - -- 1. Determine join-point-hood of whole group, as determined by - -- the *unadjusted* usage details - unadj_uds = foldr andUDs body_uds rhs_udss - will_be_joins = decideJoinPointHood lvl unadj_uds bndrs - - -- 2. Adjust usage details of each RHS, taking into account the - -- join-point-hood decision - rhs_udss' = map adjust triples - adjust (bndr, rhs_uds, rhs_bndrs) - = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds - where - -- Can't use willBeJoinId_maybe here because we haven't tagged the - -- binder yet (the tag depends on these adjustments!) - mb_join_arity - | will_be_joins - , let occ = lookupDetails unadj_uds bndr - , AlwaysTailCalled arity <- tailCallInfo occ - = Just arity - | otherwise - = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if - Nothing -- we are making join points! - - -- 3. Compute final usage details from adjusted RHS details - adj_uds = foldr andUDs body_uds rhs_udss' - - -- 4. Tag each binder with its adjusted details - bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr - | bndr <- bndrs ] - - -- 5. Drop the binders from the adjusted details and return - usage' = adj_uds `delDetailsList` bndrs - in - (usage', bndrs') - -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr -setBinderOcc occ_info bndr - | isTyVar bndr = bndr - | isExportedId bndr = if isManyOccs (idOccInfo bndr) - then bndr - else setIdOccInfo bndr noOccInfo - -- Don't use local usage info for visible-elsewhere things - -- BUT *do* erase any IAmALoopBreaker annotation, because we're - -- about to re-generate it and it shouldn't be "sticky" - - | otherwise = setIdOccInfo bndr occ_info - --- | Decide whether some bindings should be made into join points or not. --- Returns `False` if they can't be join points. Note that it's an --- all-or-nothing decision, as if multiple binders are given, they're --- assumed to be mutually recursive. --- --- It must, however, be a final decision. If we say "True" for 'f', --- and then subsequently decide /not/ make 'f' into a join point, then --- the decision about another binding 'g' might be invalidated if (say) --- 'f' tail-calls 'g'. --- --- See Note [Invariants on join points] in GHC.Core. -decideJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] - -> Bool -decideJoinPointHood TopLevel _ _ - = False -decideJoinPointHood NotTopLevel usage bndrs - | isJoinId (head bndrs) - = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> - ppr bndrs) - all_ok - | otherwise - = all_ok - where - -- See Note [Invariants on join points]; invariants cited by number below. - -- Invariant 2 is always satisfiable by the simplifier by eta expansion. - all_ok = -- Invariant 3: Either all are join points or none are - all ok bndrs - - ok bndr - | -- Invariant 1: Only tail calls, all same join arity - AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) - - , -- Invariant 1 as applied to LHSes of rules - all (ok_rule arity) (idCoreRules bndr) - - -- Invariant 2a: stable unfoldings - -- See Note [Join points and INLINE pragmas] - , ok_unfolding arity (realIdUnfolding bndr) - - -- Invariant 4: Satisfies polymorphism rule - , isValidJoinPointType arity (idType bndr) - = True - - | otherwise - = False - - ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans - ok_rule join_arity (Rule { ru_args = args }) - = args `lengthIs` join_arity - -- Invariant 1 as applied to LHSes of rules - - -- ok_unfolding returns False if we should /not/ convert a non-join-id - -- into a join-id, even though it is AlwaysTailCalled - ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) - = not (isStableSource src && join_arity > joinRhsArity rhs) - ok_unfolding _ (DFunUnfolding {}) - = False - ok_unfolding _ _ - = True - -willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity -willBeJoinId_maybe bndr - = case tailCallInfo (idOccInfo bndr) of - AlwaysTailCalled arity -> Just arity - _ -> isJoinId_maybe bndr - - -{- Note [Join points and INLINE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let g = \x. not -- Arity 1 - {-# INLINE g #-} - in case x of - A -> g True True - B -> g True False - C -> blah2 - -Here 'g' is always tail-called applied to 2 args, but the stable -unfolding captured by the INLINE pragma has arity 1. If we try to -convert g to be a join point, its unfolding will still have arity 1 -(since it is stable, and we don't meddle with stable unfoldings), and -Lint will complain (see Note [Invariants on join points], (2a), in -GHC.Core. #13413. - -Moreover, since g is going to be inlined anyway, there is no benefit -from making it a join point. - -If it is recursive, and uselessly marked INLINE, this will stop us -making it a join point, which is annoying. But occasionally -(notably in class methods; see Note [Instances and loop breakers] in -TcInstDcls) we mark recursive things as INLINE but the recursion -unravels; so ignoring INLINE pragmas on recursive things isn't good -either. - -See Invariant 2a of Note [Invariants on join points] in GHC.Core - - -************************************************************************ -* * -\subsection{Operations over OccInfo} -* * -************************************************************************ --} - -markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo - -markMany IAmDead = IAmDead -markMany occ = ManyOccs { occ_tail = occ_tail occ } - -markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } -markInsideLam occ = occ - -markNonTailCalled IAmDead = IAmDead -markNonTailCalled occ = occ { occ_tail = NoTailCallInfo } - -addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo - -addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -- Both branches are at least One - -- (Argument is never IAmDead) - --- (orOccInfo orig new) is used --- when combining occurrence info from branches of a case - -orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 - , occ_tail = tail1 }) - (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 - , occ_tail = tail2 }) - = OneOcc { occ_one_br = MultipleBranches -- because it occurs in both branches - , occ_in_lam = in_lam1 `mappend` in_lam2 - , occ_int_cxt = int_cxt1 `mappend` int_cxt2 - , occ_tail = tail1 `andTailCallInfo` tail2 } - -orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo -andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) - | arity1 == arity2 = info -andTailCallInfo _ _ = NoTailCallInfo diff --git a/compiler/typecheck/Constraint.hs b/compiler/typecheck/Constraint.hs --- a/compiler/typecheck/Constraint.hs +++ b/compiler/typecheck/Constraint.hs @@ -14,7 +14,7 @@ QCInst(..), isPendingScInst, -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, + Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts, singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, isEmptyCts, isCTyEqCan, isCFunEqCan, isPendingScDict, superClassesMightHelp, getPendingWantedScs, @@ -25,7 +25,7 @@ ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, ctEvId, mkTcEqPredLikeEv, mkNonCanonical, mkNonCanonicalCt, mkGivens, - mkIrredCt, mkInsolubleCt, + mkIrredCt, ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, tyCoVarsOfCt, tyCoVarsOfCts, @@ -55,7 +55,7 @@ isWanted, isGiven, isDerived, isGivenOrWDeriv, ctEvRole, - wrapType, wrapTypeWithImplication, + wrapType, CtFlavour(..), ShadowInfo(..), ctEvFlavour, CtFlavourRole, ctEvFlavourRole, ctFlavourRole, @@ -80,13 +80,12 @@ import {-# SOURCE #-} TcRnTypes ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel , setLclEnvLoc, getLclEnvLoc ) -import Predicate -import Type -import Coercion -import Class -import TyCon -import Var -import Id +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Types.Var import TcType import TcEvidence @@ -94,15 +93,15 @@ import GHC.Core -import TyCoPpr -import OccName +import GHC.Core.TyCo.Ppr +import GHC.Types.Name.Occurrence import FV -import VarSet +import GHC.Types.Var.Set import GHC.Driver.Session -import BasicTypes +import GHC.Types.Basic import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Bag import Util @@ -146,13 +145,12 @@ } | CIrredCan { -- These stand for yet-unusable predicates - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_insol :: Bool -- True <=> definitely an error, can never be solved - -- False <=> might be soluble + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_status :: CtIrredStatus -- For the might-be-soluble case, the ctev_pred of the evidence is -- of form (tv xi1 xi2 ... xin) with a tyvar at the head - -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails + -- or (tv1 ~ ty2) where the CTyEqCan kind invariant (TyEq:K) fails -- or (F tys ~ ty) where the CFunEqCan kind invariant fails -- See Note [CIrredCan constraints] @@ -164,19 +162,21 @@ | CTyEqCan { -- tv ~ rhs -- Invariants: -- * See Note [inert_eqs: the inert equalities] in TcSMonad - -- * tv not in tvs(rhs) (occurs check) - -- * If tv is a TauTv, then rhs has no foralls + -- * (TyEq:OC) tv not in deep tvs(rhs) (occurs check) + -- * (TyEq:F) If tv is a TauTv, then rhs has no foralls -- (this avoids substituting a forall for the tyvar in other types) - -- * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] - -- * rhs may have at most one top-level cast - -- * rhs (perhaps under the one cast) is *almost function-free*, + -- * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] + -- * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*, -- See Note [Almost function-free] - -- * If the equality is representational, rhs has no top-level newtype + -- * (TyEq:N) If the equality is representational, rhs has no top-level newtype -- See Note [No top-level newtypes on RHS of representational -- equalities] in TcCanonical - -- * If rhs (perhaps under the cast) is also a tv, then it is oriented + -- * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented -- to give best chance of -- unification happening; eg if rhs is touchable then lhs is too + -- See TcCanonical Note [Canonical orientation for tyvar/tyvar equality constraints] + -- * (TyEq:H) The RHS has no blocking coercion holes. See TcCanonical + -- Note [Equalities with incompatible kinds], wrinkle (2) cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) @@ -242,6 +242,21 @@ | TypeHole -- ^ A hole in a type (PartialTypeSignatures) +------------ +-- | Used to indicate extra information about why a CIrredCan is irreducible +data CtIrredStatus + = InsolubleCIS -- this constraint will never be solved + | BlockedCIS -- this constraint is blocked on a coercion hole + -- The hole will appear in the ctEvPred of the constraint with this status + -- See Note [Equalities with incompatible kinds] in TcCanonical + -- Wrinkle (4a) + | OtherCIS + +instance Outputable CtIrredStatus where + ppr InsolubleCIS = text "(insoluble)" + ppr BlockedCIS = text "(blocked)" + ppr OtherCIS = text "(soluble)" + {- Note [Hole constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~ CHoleCan constraints are used for two kinds of holes, @@ -297,7 +312,8 @@ * under a forall, or * in a coercion (either in a CastTy or a CercionTy) -The RHS of a CTyEqCan must be almost function-free. This is for two reasons: +The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF). +This is for two reasons: 1. There cannot be a top-level function. If there were, the equality should really be a CFunEqCan, not a CTyEqCan. @@ -347,11 +363,8 @@ mkNonCanonicalCt :: Ct -> Ct mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } -mkIrredCt :: CtEvidence -> Ct -mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False } - -mkInsolubleCt :: CtEvidence -> Ct -mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True } +mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct +mkIrredCt status ev = CIrredCan { cc_ev = ev, cc_status = status } mkGivens :: CtLoc -> [EvId] -> [Ct] mkGivens loc ev_ids @@ -410,9 +423,7 @@ CDictCan { cc_pend_sc = pend_sc } | pend_sc -> text "CDictCan(psc)" | otherwise -> text "CDictCan" - CIrredCan { cc_insol = insol } - | insol -> text "CIrredCan(insol)" - | otherwise -> text "CIrredCan(sol)" + CIrredCan { cc_status = status } -> text "CIrredCan" <> ppr status CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ CQuantCan (QCI { qci_pend_sc = pend_sc }) | pend_sc -> text "CQuantCan(psc)" @@ -440,14 +451,10 @@ -- | Returns free variables of constraints as a composable FV computation. -- See Note [Deterministic FV] in FV. tyCoFVsOfCt :: Ct -> FV -tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = tyCoFVsOfType xi `unionFV` FV.unitFV tv - `unionFV` tyCoFVsOfType (tyVarKind tv) -tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) - = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk - `unionFV` tyCoFVsOfType (tyVarKind fsk) -tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) + -- This must consult only the ctPred, so that it gets *tidied* fvs if the + -- constraint has been tidied. Tidying a constraint does not tidy the + -- fields of the Ct, only the predicate in the CtEvidence. -- | Returns free variables of a bag of constraints as a non-deterministic -- set. See Note [Deterministic FV] in FV. @@ -550,18 +557,15 @@ keep_deriv = case ct of - CHoleCan {} -> True - CIrredCan { cc_insol = insoluble } - -> keep_eq insoluble - _ -> keep_eq False + CHoleCan {} -> True + CIrredCan { cc_status = InsolubleCIS } -> keep_eq True + _ -> keep_eq False keep_eq definitely_insoluble | isGivenOrigin orig -- Arising only from givens = definitely_insoluble -- Keep only definitely insoluble | otherwise = case orig of - KindEqOrigin {} -> True -- See Note [Dropping derived constraints] - -- See Note [Dropping derived constraints] -- For fundeps, drop wanted/wanted interactions FunDepOrigin2 {} -> True -- Top-level/Wanted @@ -611,12 +615,6 @@ * Type holes are derived constraints, because they have no evidence and we want to keep them, so we get the error report - * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with - KindEqOrigin, may arise from a type equality a ~ Int#, say. See - Note [Equalities with incompatible kinds] in TcCanonical. - Keeping these around produces better error messages, in practice. - E.g., test case dependent/should_fail/T11471 - * We keep most derived equalities arising from functional dependencies - Given/Given interactions (subset of FunDepOrigin1): The definitely-insoluble ones reflect unreachable code. @@ -665,7 +663,6 @@ isCTyEqCan :: Ct -> Bool isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan (CFunEqCan {}) = False isCTyEqCan _ = False isCDictCan_Maybe :: Ct -> Maybe Class @@ -991,8 +988,8 @@ -- True for Int ~ F a Int -- but False for Maybe Int ~ F a Int Int -- (where F is an arity-1 type function) -insolubleEqCt (CIrredCan { cc_insol = insol }) = insol -insolubleEqCt _ = False +insolubleEqCt (CIrredCan { cc_status = InsolubleCIS }) = True +insolubleEqCt _ = False instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i}) @@ -1292,17 +1289,6 @@ --- | Wraps the given type with the constraints (via ic_given) in the given --- implication, according to the variables mentioned (via ic_skols) --- in the implication, but taking care to only wrap those variables --- that are mentioned in the type or the implication. -wrapTypeWithImplication :: Type -> Implication -> Type -wrapTypeWithImplication ty impl = wrapType ty mentioned_skols givens - where givens = map idType $ ic_given impl - skols = ic_skols impl - freeVars = fvVarSet $ tyCoFVsOfTypes (ty:givens) - mentioned_skols = filter (`elemVarSet` freeVars) skols - wrapType :: Type -> [TyVar] -> [PredType] -> Type wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty @@ -1356,7 +1342,7 @@ | HoleDest CoercionHole -- ^ fill in this hole with the evidence -- HoleDest is always used for type-equalities - -- See Note [Coercion holes] in TyCoRep + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep data CtEvidence = CtGiven -- Truly given, not depending on subgoals diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -55,33 +55,33 @@ import GhcPrelude -import Var -import CoAxiom -import Coercion +import GHC.Types.Var +import GHC.Core.Coercion.Axiom +import GHC.Core.Coercion import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import TcType -import Type -import TyCon -import DataCon( DataCon, dataConWrapId ) -import Class( Class ) +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon( DataCon, dataConWrapId ) +import GHC.Core.Class( Class ) import PrelNames -import VarEnv -import VarSet -import Predicate -import Name +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.Predicate +import GHC.Types.Name import Pair import GHC.Core -import Class ( classSCSelId ) -import GHC.Core.FVs ( exprSomeFreeVars ) +import GHC.Core.Class ( classSCSelId ) +import GHC.Core.FVs ( exprSomeFreeVars ) import Util import Bag import qualified Data.Data as Data import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Data.IORef( IORef ) -import UniqSet +import GHC.Types.Unique.Set {- Note [TcCoercions] @@ -442,8 +442,7 @@ evidence bindings are allowed. Notebly (): - Places in types where we are solving kind constraints (all of which - are equalities); see solveEqualities, solveLocalEqualities, - checkTvConstraints + are equalities); see solveEqualities, solveLocalEqualities - When unifying forall-types -} @@ -473,7 +472,7 @@ -- let $dNum = GHC.Num.$fNumInt in -- let $dEq = GHC.Classes.$fEqInt in ... -- - -- See Note [Deterministic UniqFM] in UniqDFM for explanation why + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why -- @UniqFM@ can lead to nondeterministic order. emptyEvBindMap :: EvBindMap diff --git a/compiler/typecheck/TcHoleFitTypes.hs b/compiler/typecheck/TcHoleFitTypes.hs --- a/compiler/typecheck/TcHoleFitTypes.hs +++ b/compiler/typecheck/TcHoleFitTypes.hs @@ -11,13 +11,13 @@ import Constraint import TcType -import RdrName +import GHC.Types.Name.Reader import GHC.Hs.Doc -import Id +import GHC.Types.Id import Outputable -import Name +import GHC.Types.Name import Data.Function ( on ) diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs --- a/compiler/typecheck/TcOrigin.hs +++ b/compiler/typecheck/TcOrigin.hs @@ -33,21 +33,21 @@ import GHC.Hs -import Id -import DataCon -import ConLike -import TyCon -import InstEnv -import PatSyn +import GHC.Types.Id +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.PatSyn -import Module -import Name -import RdrName +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Name.Reader -import SrcLoc +import GHC.Types.SrcLoc import FastString import Outputable -import BasicTypes +import GHC.Types.Basic {- ********************************************************************* * * @@ -363,7 +363,7 @@ -- visible.) Only used for prioritizing error messages. } - | KindEqOrigin -- See Note [Equalities with incompatible kinds] in TcCanonical. + | KindEqOrigin TcType (Maybe TcType) -- A kind equality arising from unifying these two types CtOrigin -- originally arising from this (Maybe TypeOrKind) -- the level of the eq this arises from diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -88,32 +88,32 @@ import GHC.Hs import GHC.Driver.Types import TcEvidence -import Type -import TyCon ( TyCon, tyConKind ) -import PatSyn ( PatSyn ) -import Id ( idType, idName ) -import FieldLabel ( FieldLabel ) +import GHC.Core.Type +import GHC.Core.TyCon ( TyCon, tyConKind ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Types.Id ( idType, idName ) +import GHC.Types.FieldLabel ( FieldLabel ) import TcType import Constraint import TcOrigin -import Annotations -import InstEnv -import FamInstEnv +import GHC.Types.Annotations +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas) import IOEnv -import RdrName -import Name -import NameEnv -import NameSet -import Avail -import Var -import VarEnv -import Module -import SrcLoc -import VarSet +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Module +import GHC.Types.SrcLoc +import GHC.Types.Var.Set import ErrUtils -import UniqFM -import BasicTypes +import GHC.Types.Unique.FM +import GHC.Types.Basic import Bag import GHC.Driver.Session import Outputable @@ -121,10 +121,9 @@ import Fingerprint import Util import PrelNames ( isUnboundName ) -import CostCentreState +import GHC.Types.CostCentre.State import Control.Monad (ap) -import qualified Control.Monad.Fail as MonadFail import Data.Set ( Set ) import qualified Data.Set as S @@ -384,7 +383,7 @@ -- -- - For any code involving Names, we want semantic modules. -- See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints --- in GHC.Iface.Utils, and tcLookupGlobal in TcEnv +-- in GHC.Iface.{Make,Recomp}, and tcLookupGlobal in TcEnv -- -- - When reading interfaces, we want the identity module to -- identify the specific interface we want (such interfaces @@ -664,7 +663,7 @@ Used (a) to report "defined but not used" (see GHC.Rename.Names.reportUnusedNames) (b) to generate version-tracking usage info in interface - files (see GHC.Iface.Utils.mkUsedNames) + files (see GHC.Iface.Make.mkUsedNames) This usage info is mainly gathered by the renamer's gathering of free-variables @@ -1653,14 +1652,11 @@ (<*>) = ap instance Monad TcPluginM where -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif TcPluginM m >>= k = TcPluginM (\ ev -> do a <- m ev runTcPluginM (k a) ev) -instance MonadFail.MonadFail TcPluginM where +instance MonadFail TcPluginM where fail x = TcPluginM (const $ fail x) runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a diff --git a/compiler/typecheck/TcRnTypes.hs-boot b/compiler/typecheck/TcRnTypes.hs-boot --- a/compiler/typecheck/TcRnTypes.hs-boot +++ b/compiler/typecheck/TcRnTypes.hs-boot @@ -1,7 +1,7 @@ module TcRnTypes where import TcType -import SrcLoc +import GHC.Types.SrcLoc data TcLclEnv diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -68,7 +68,7 @@ tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, tcRepGetNumAppTys, - tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole, + tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe, --------------------------------- @@ -193,32 +193,32 @@ -- friends: import GhcPrelude -import TyCoRep -import TyCoSubst ( mkTvSubst, substTyWithCoVars ) -import TyCoFVs -import TyCoPpr -import Class -import Var -import ForeignCall -import VarSet -import Coercion -import Type -import Predicate +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.Class +import GHC.Types.Var +import GHC.Types.ForeignCall +import GHC.Types.Var.Set +import GHC.Core.Coercion +import GHC.Core.Type as Type +import GHC.Core.Predicate import GHC.Types.RepType -import TyCon +import GHC.Core.TyCon -- others: import GHC.Driver.Session import GHC.Core.FVs -import Name -- hiding (varName) +import GHC.Types.Name as Name -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? -import NameSet -import VarEnv +import GHC.Types.Name.Set +import GHC.Types.Var.Env import PrelNames import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey , listTyCon, constraintKind ) -import BasicTypes +import GHC.Types.Basic import Util import Maybes import ListSetOps ( getNth, findDupsEq ) @@ -508,7 +508,7 @@ -- how this level number is used Bool -- True <=> this skolem type variable can be overlapped -- when looking up instances - -- See Note [Binding when looking up instances] in InstEnv + -- See Note [Binding when looking up instances] in GHC.Core.InstEnv | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi -- interactive context @@ -518,7 +518,7 @@ , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] vanillaSkolemTv, superSkolemTv :: TcTyVarDetails --- See Note [Binding when looking up instances] in InstEnv +-- See Note [Binding when looking up instances] in GHC.Core.InstEnv vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type -- The choice of level number here is a bit dodgy, but @@ -853,6 +853,10 @@ anyRewritableTyVar ignore_cos role pred ty = go role emptyVarSet ty where + -- NB: No need to expand synonyms, because we can find + -- all free variables of a synonym by looking at its + -- arguments + go_tv rl bvs tv | tv `elemVarSet` bvs = False | otherwise = pred rl tv @@ -860,7 +864,10 @@ go _ _ (LitTy {}) = False go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg - go rl bvs (FunTy _ arg res) = go rl bvs arg || go rl bvs res + go rl bvs (FunTy _ arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || + go rl bvs arg || go rl bvs res + where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 + res_rep = getRuntimeRep res go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check @@ -914,7 +921,7 @@ which type variables are mentioned in a type. It only matters occasionally -- see the calls to exactTyCoVarsOfType. -We place this function here in TcType, note in TyCoFVs, +We place this function here in TcType, not in GHC.Core.TyCo.FVs, because we want to "see" tcView (efficiency issue only). -} @@ -1487,7 +1494,7 @@ tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool -- tcEqType is a proper implements the same Note [Non-trivial definitional --- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* == +-- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* == -- Constraint), and that is NOT what we want in the type checker! tcEqType ty1 ty2 = tc_eq_type False False ki1 ki2 @@ -1549,7 +1556,7 @@ go env ty (FunTy _ arg res) = eqFunTy env arg res ty go env (FunTy _ arg res) ty = eqFunTy env arg res ty - -- See Note [Equality on AppTys] in Type + -- See Note [Equality on AppTys] in GHC.Core.Type go env (AppTy s1 t1) ty2 | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 = go env s1 s2 && go env t1 t2 @@ -1916,7 +1923,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't quantify over a constraint (t1 ~# t2) because that isn't a predicate type; see Note [Types for coercions, predicates, and evidence] -in TyCoRep. +in GHC.Core.TyCo.Rep. So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted to Coercible. diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs deleted file mode 100644 --- a/compiler/types/Class.hs +++ /dev/null @@ -1,360 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- --- The @Class@ datatype - -{-# LANGUAGE CPP #-} - -module Class ( - Class, - ClassOpItem, - ClassATItem(..), - ClassMinimalDef, - DefMethInfo, pprDefMethInfo, - - FunDep, pprFundeps, pprFunDep, - - mkClass, mkAbstractClass, classTyVars, classArity, - classKey, className, classATs, classATItems, classTyCon, classMethods, - classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, - classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, - isAbstractClass, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep ( Type, PredType ) -import {-# SOURCE #-} TyCoPpr ( pprType ) -import Var -import Name -import BasicTypes -import Unique -import Util -import SrcLoc -import Outputable -import BooleanFormula (BooleanFormula, mkTrue) - -import qualified Data.Data as Data - -{- -************************************************************************ -* * -\subsection[Class-basic]{@Class@: basic definition} -* * -************************************************************************ - -A @Class@ corresponds to a Greek kappa in the static semantics: --} - -data Class - = Class { - classTyCon :: TyCon, -- The data type constructor for - -- dictionaries of this class - -- See Note [ATyCon for classes] in TyCoRep - - className :: Name, -- Just the cached name of the TyCon - classKey :: Unique, -- Cached unique of TyCon - - classTyVars :: [TyVar], -- The class kind and type variables; - -- identical to those of the TyCon - -- If you want visibility info, look at the classTyCon - -- This field is redundant because it's duplicated in the - -- classTyCon, but classTyVars is used quite often, so maybe - -- it's a bit faster to cache it here - - classFunDeps :: [FunDep TyVar], -- The functional dependencies - - classBody :: ClassBody -- Superclasses, ATs, methods - - } - --- | e.g. --- --- > class C a b c | a b -> c, a c -> b where... --- --- Here fun-deps are [([a,b],[c]), ([a,c],[b])] --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', - --- For details on above see note [Api annotations] in ApiAnnotation -type FunDep a = ([a],[a]) - -type ClassOpItem = (Id, DefMethInfo) - -- Selector function; contains unfolding - -- Default-method info - -type DefMethInfo = Maybe (Name, DefMethSpec Type) - -- Nothing No default method - -- Just ($dm, VanillaDM) A polymorphic default method, name $dm - -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty - -- The generic dm type is *not* quantified - -- over the class variables; ie has the - -- class variables free - -data ClassATItem - = ATI TyCon -- See Note [Associated type tyvar names] - (Maybe (Type, SrcSpan)) - -- Default associated type (if any) from this template - -- Note [Associated type defaults] - -type ClassMinimalDef = BooleanFormula Name -- Required methods - -data ClassBody - = AbstractClass - | ConcreteClass { - -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) - -- We need value-level selectors for both the dictionary - -- superclasses and the equality superclasses - cls_sc_theta :: [PredType], -- Immediate superclasses, - cls_sc_sel_ids :: [Id], -- Selector functions to extract the - -- superclasses from a - -- dictionary of this class - -- Associated types - cls_ats :: [ClassATItem], -- Associated type families - - -- Class operations (methods, not superclasses) - cls_ops :: [ClassOpItem], -- Ordered by tag - - -- Minimal complete definition - cls_min_def :: ClassMinimalDef - } - -- TODO: maybe super classes should be allowed in abstract class definitions - -classMinimalDef :: Class -> ClassMinimalDef -classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d -classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction - -{- -Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following is an example of associated type defaults: - class C a where - data D a r - - type F x a b :: * - type F p q r = (p,q)->r -- Default - -Note that - - * The TyCons for the associated types *share type variables* with the - class, so that we can tell which argument positions should be - instantiated in an instance decl. (The first for 'D', the second - for 'F'.) - - * We can have default definitions only for *type* families, - not data families - - * In the default decl, the "patterns" should all be type variables, - but (in the source language) they don't need to be the same as in - the 'type' decl signature or the class. It's more like a - free-standing 'type instance' declaration. - - * HOWEVER, in the internal ClassATItem we rename the RHS to match the - tyConTyVars of the family TyCon. So in the example above we'd get - a ClassATItem of - ATI F ((x,a) -> b) - So the tyConTyVars of the family TyCon bind the free vars of - the default Type rhs - -The @mkClass@ function fills in the indirect superclasses. - -The SrcSpan is for the entire original declaration. --} - -mkClass :: Name -> [TyVar] - -> [FunDep TyVar] - -> [PredType] -> [Id] - -> [ClassATItem] - -> [ClassOpItem] - -> ClassMinimalDef - -> TyCon - -> Class - -mkClass cls_name tyvars fds super_classes superdict_sels at_stuff - op_stuff mindef tycon - = Class { classKey = nameUnique cls_name, - className = cls_name, - -- NB: tyConName tycon = cls_name, - -- But it takes a module loop to assert it here - classTyVars = tyvars, - classFunDeps = fds, - classBody = ConcreteClass { - cls_sc_theta = super_classes, - cls_sc_sel_ids = superdict_sels, - cls_ats = at_stuff, - cls_ops = op_stuff, - cls_min_def = mindef - }, - classTyCon = tycon } - -mkAbstractClass :: Name -> [TyVar] - -> [FunDep TyVar] - -> TyCon - -> Class - -mkAbstractClass cls_name tyvars fds tycon - = Class { classKey = nameUnique cls_name, - className = cls_name, - -- NB: tyConName tycon = cls_name, - -- But it takes a module loop to assert it here - classTyVars = tyvars, - classFunDeps = fds, - classBody = AbstractClass, - classTyCon = tycon } - -{- -Note [Associated type tyvar names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The TyCon of an associated type should use the same variable names as its -parent class. Thus - class C a b where - type F b x a :: * -We make F use the same Name for 'a' as C does, and similarly 'b'. - -The reason for this is when checking instances it's easier to match -them up, to ensure they match. Eg - instance C Int [d] where - type F [d] x Int = .... -we should make sure that the first and third args match the instance -header. - -Having the same variables for class and tycon is also used in checkValidRoles -(in TcTyClsDecls) when checking a class's roles. - - -************************************************************************ -* * -\subsection[Class-selectors]{@Class@: simple selectors} -* * -************************************************************************ - -The rest of these functions are just simple selectors. --} - -classArity :: Class -> Arity -classArity clas = length (classTyVars clas) - -- Could memoise this - -classAllSelIds :: Class -> [Id] --- Both superclass-dictionary and method selectors -classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) - = sc_sels ++ classMethods c -classAllSelIds c = ASSERT( null (classMethods c) ) [] - -classSCSelIds :: Class -> [Id] --- Both superclass-dictionary and method selectors -classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) - = sc_sels -classSCSelIds c = ASSERT( null (classMethods c) ) [] - -classSCSelId :: Class -> Int -> Id --- Get the n'th superclass selector Id --- where n is 0-indexed, and counts --- *all* superclasses including equalities -classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n - = ASSERT( n >= 0 && lengthExceeds sc_sels n ) - sc_sels !! n -classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) - -classMethods :: Class -> [Id] -classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) - = [op_sel | (op_sel, _) <- op_stuff] -classMethods _ = [] - -classOpItems :: Class -> [ClassOpItem] -classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) - = op_stuff -classOpItems _ = [] - -classATs :: Class -> [TyCon] -classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) - = [tc | ATI tc _ <- at_stuff] -classATs _ = [] - -classATItems :: Class -> [ClassATItem] -classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) - = at_stuff -classATItems _ = [] - -classSCTheta :: Class -> [PredType] -classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) - = theta_stuff -classSCTheta _ = [] - -classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) -classTvsFds c = (classTyVars c, classFunDeps c) - -classHasFds :: Class -> Bool -classHasFds (Class { classFunDeps = fds }) = not (null fds) - -classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) -classBigSig (Class {classTyVars = tyvars, - classBody = AbstractClass}) - = (tyvars, [], [], []) -classBigSig (Class {classTyVars = tyvars, - classBody = ConcreteClass { - cls_sc_theta = sc_theta, - cls_sc_sel_ids = sc_sels, - cls_ops = op_stuff - }}) - = (tyvars, sc_theta, sc_sels, op_stuff) - -classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) -classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, - classBody = AbstractClass}) - = (tyvars, fundeps, [], [], [], []) -classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, - classBody = ConcreteClass { - cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, - cls_ats = ats, cls_ops = op_stuff - }}) - = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) - -isAbstractClass :: Class -> Bool -isAbstractClass Class{ classBody = AbstractClass } = True -isAbstractClass _ = False - -{- -************************************************************************ -* * -\subsection[Class-instances]{Instance declarations for @Class@} -* * -************************************************************************ - -We compare @Classes@ by their keys (which include @Uniques@). --} - -instance Eq Class where - c1 == c2 = classKey c1 == classKey c2 - c1 /= c2 = classKey c1 /= classKey c2 - -instance Uniquable Class where - getUnique c = classKey c - -instance NamedThing Class where - getName clas = className clas - -instance Outputable Class where - ppr c = ppr (getName c) - -pprDefMethInfo :: DefMethInfo -> SDoc -pprDefMethInfo Nothing = empty -- No default method -pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n -pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" - <+> ppr n <+> dcolon <+> pprType ty - -pprFundeps :: Outputable a => [FunDep a] -> SDoc -pprFundeps [] = empty -pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) - -pprFunDep :: Outputable a => FunDep a -> SDoc -pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] - -instance Data.Data Class where - -- don't traverse? - toConstr _ = abstractConstr "Class" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Class" diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs deleted file mode 100644 --- a/compiler/types/CoAxiom.hs +++ /dev/null @@ -1,573 +0,0 @@ --- (c) The University of Glasgow 2012 - -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, - ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} - --- | Module for coercion axioms, used to represent type family instances --- and newtypes - -module CoAxiom ( - BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), - manyBranches, unbranched, - fromBranches, numBranches, - mapAccumBranches, - - CoAxiom(..), CoAxBranch(..), - - toBranchedAxiom, toUnbranchedAxiom, - coAxiomName, coAxiomArity, coAxiomBranches, - coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, - coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, - coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, - coAxBranchRoles, - coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, - placeHolderIncomps, - - Role(..), fsFromRole, - - CoAxiomRule(..), TypeEqn, - BuiltInSynFamily(..), trivialBuiltInFamily - ) where - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep ( Type ) -import {-# SOURCE #-} TyCoPpr ( pprType ) -import {-# SOURCE #-} TyCon ( TyCon ) -import Outputable -import FastString -import Name -import Unique -import Var -import Util -import Binary -import Pair -import BasicTypes -import Data.Typeable ( Typeable ) -import SrcLoc -import qualified Data.Data as Data -import Data.Array -import Data.List ( mapAccumL ) - -#include "HsVersions.h" - -{- -Note [Coercion axiom branches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to allow closed type families, an axiom needs to contain an -ordered list of alternatives, called branches. The kind of the coercion built -from an axiom is determined by which index is used when building the coercion -from the axiom. - -For example, consider the axiom derived from the following declaration: - -type family F a where - F [Int] = Bool - F [a] = Double - F (a b) = Char - -This will give rise to this axiom: - -axF :: { F [Int] ~ Bool - ; forall (a :: *). F [a] ~ Double - ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char - } - -The axiom is used with the AxiomInstCo constructor of Coercion. If we wish -to have a coercion showing that F (Maybe Int) ~ Char, it will look like - -axF[2] <*> :: F (Maybe Int) ~ Char --- or, written using concrete-ish syntax -- -AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] - -Note that the index is 0-based. - -For type-checking, it is also necessary to check that no previous pattern -can unify with the supplied arguments. After all, it is possible that some -of the type arguments are lambda-bound type variables whose instantiation may -cause an earlier match among the branches. We wish to prohibit this behavior, -so the type checker rules out the choice of a branch where a previous branch -can unify. See also [Apartness] in FamInstEnv.hs. - -For example, the following is malformed, where 'a' is a lambda-bound type -variable: - -axF[2] <*> :: F (a Bool) ~ Char - -Why? Because a might be instantiated with [], meaning that branch 1 should -apply, not branch 2. This is a vital consistency check; without it, we could -derive Int ~ Bool, and that is a Bad Thing. - -Note [Branched axioms] -~~~~~~~~~~~~~~~~~~~~~~ -Although a CoAxiom has the capacity to store many branches, in certain cases, -we want only one. These cases are in data/newtype family instances, newtype -coercions, and type family instances. -Furthermore, these unbranched axioms are used in a -variety of places throughout GHC, and it would difficult to generalize all of -that code to deal with branched axioms, especially when the code can be sure -of the fact that an axiom is indeed a singleton. At the same time, it seems -dangerous to assume singlehood in various places through GHC. - -The solution to this is to label a CoAxiom with a phantom type variable -declaring whether it is known to be a singleton or not. The branches -are stored using a special datatype, declared below, that ensures that the -type variable is accurate. - -************************************************************************ -* * - Branches -* * -************************************************************************ --} - -type BranchIndex = Int -- The index of the branch in the list of branches - -- Counting from zero - --- promoted data type -data BranchFlag = Branched | Unbranched -type Branched = 'Branched -type Unbranched = 'Unbranched --- By using type synonyms for the promoted constructors, we avoid needing --- DataKinds and the promotion quote in client modules. This also means that --- we don't need to export the term-level constructors, which should never be used. - -newtype Branches (br :: BranchFlag) - = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } -type role Branches nominal - -manyBranches :: [CoAxBranch] -> Branches Branched -manyBranches brs = ASSERT( snd bnds >= fst bnds ) - MkBranches (listArray bnds brs) - where - bnds = (0, length brs - 1) - -unbranched :: CoAxBranch -> Branches Unbranched -unbranched br = MkBranches (listArray (0, 0) [br]) - -toBranched :: Branches br -> Branches Branched -toBranched = MkBranches . unMkBranches - -toUnbranched :: Branches br -> Branches Unbranched -toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) - MkBranches arr - -fromBranches :: Branches br -> [CoAxBranch] -fromBranches = elems . unMkBranches - -branchesNth :: Branches br -> BranchIndex -> CoAxBranch -branchesNth (MkBranches arr) n = arr ! n - -numBranches :: Branches br -> Int -numBranches (MkBranches arr) = snd (bounds arr) + 1 - --- | The @[CoAxBranch]@ passed into the mapping function is a list of --- all previous branches, reversed -mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) - -> Branches br -> Branches br -mapAccumBranches f (MkBranches arr) - = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) - where - go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) - go prev_branches cur_branch = ( cur_branch : prev_branches - , f prev_branches cur_branch ) - - -{- -************************************************************************ -* * - Coercion axioms -* * -************************************************************************ - -Note [Storing compatibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During axiom application, we need to be aware of which branches are compatible -with which others. The full explanation is in Note [Compatibility] in -FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on -the unification algorithm.) Although we could theoretically compute -compatibility on the fly, this is silly, so we store it in a CoAxiom. - -Specifically, each branch refers to all other branches with which it is -incompatible. This list might well be empty, and it will always be for the -first branch of any axiom. - -CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk -stored in cab_incomps. The incompatibilities are properly a property of the -axiom as a whole, and they are computed only when the final axiom is built. - -During serialization, the list is converted into a list of the indices -of the branches. --} - --- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -data CoAxiom br - = CoAxiom -- Type equality axiom. - { co_ax_unique :: Unique -- Unique identifier - , co_ax_name :: Name -- Name for pretty-printing - , co_ax_role :: Role -- Role of the axiom's equality - , co_ax_tc :: TyCon -- The head of the LHS patterns - -- e.g. the newtype or family tycon - , co_ax_branches :: Branches br -- The branches that form this axiom - , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" - -- See Note [Implicit axioms] - -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. - } - -data CoAxBranch - = CoAxBranch - { cab_loc :: SrcSpan -- Location of the defining equation - -- See Note [CoAxiom locations] - , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh - , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars - -- See Note [CoAxBranch type variables] - -- cab_tvs and cab_lhs may be eta-reduded; see - -- Note [Eta reduction for data families] - , cab_cvs :: [CoVar] -- Bound coercion variables - -- Always empty, for now. - -- See Note [Constraints in patterns] - -- in TcTyClsDecls - , cab_roles :: [Role] -- See Note [CoAxBranch roles] - , cab_lhs :: [Type] -- Type patterns to match against - , cab_rhs :: Type -- Right-hand side of the equality - , cab_incomps :: [CoAxBranch] -- The previous incompatible branches - -- See Note [Storing compatibility] - } - deriving Data.Data - -toBranchedAxiom :: CoAxiom br -> CoAxiom Branched -toBranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toBranched branches) implicit - -toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched -toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toUnbranched branches) implicit - -coAxiomNumPats :: CoAxiom br -> Int -coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) - -coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch -coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index - = branchesNth bs index - -coAxiomArity :: CoAxiom br -> BranchIndex -> Arity -coAxiomArity ax index - = length tvs + length cvs - where - CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index - -coAxiomName :: CoAxiom br -> Name -coAxiomName = co_ax_name - -coAxiomRole :: CoAxiom br -> Role -coAxiomRole = co_ax_role - -coAxiomBranches :: CoAxiom br -> Branches br -coAxiomBranches = co_ax_branches - -coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch -coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) - | snd (bounds arr) == 0 - = Just $ arr ! 0 - | otherwise - = Nothing - -coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch -coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) - = arr ! 0 - -coAxiomTyCon :: CoAxiom br -> TyCon -coAxiomTyCon = co_ax_tc - -coAxBranchTyVars :: CoAxBranch -> [TyVar] -coAxBranchTyVars = cab_tvs - -coAxBranchCoVars :: CoAxBranch -> [CoVar] -coAxBranchCoVars = cab_cvs - -coAxBranchLHS :: CoAxBranch -> [Type] -coAxBranchLHS = cab_lhs - -coAxBranchRHS :: CoAxBranch -> Type -coAxBranchRHS = cab_rhs - -coAxBranchRoles :: CoAxBranch -> [Role] -coAxBranchRoles = cab_roles - -coAxBranchSpan :: CoAxBranch -> SrcSpan -coAxBranchSpan = cab_loc - -isImplicitCoAxiom :: CoAxiom br -> Bool -isImplicitCoAxiom = co_ax_implicit - -coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] -coAxBranchIncomps = cab_incomps - --- See Note [Compatibility checking] in FamInstEnv -placeHolderIncomps :: [CoAxBranch] -placeHolderIncomps = panic "placeHolderIncomps" - -{- -Note [CoAxBranch type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of a CoAxBranch of an associated type-family instance, -we use the *same* type variables (where possible) as the -enclosing class or instance. Consider - - instance C Int [z] where - type F Int [z] = ... -- Second param must be [z] - -In the CoAxBranch in the instance decl (F Int [z]) we use the -same 'z', so that it's easy to check that that type is the same -as that in the instance header. - -So, unlike FamInsts, there is no expectation that the cab_tvs -are fresh wrt each other, or any other CoAxBranch. - -Note [CoAxBranch roles] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code: - - newtype Age = MkAge Int - newtype Wrap a = MkWrap a - - convert :: Wrap Age -> Int - convert (MkWrap (MkAge i)) = i - -We want this to compile to: - - NTCo:Wrap :: forall a. Wrap a ~R a - NTCo:Age :: Age ~R Int - convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) - -But, note that NTCo:Age is at role R. Thus, we need to be able to pass -coercions at role R into axioms. However, we don't *always* want to be able to -do this, as it would be disastrous with type families. The solution is to -annotate the arguments to the axiom with roles, much like we annotate tycon -tyvars. Where do these roles get set? Newtype axioms inherit their roles from -the newtype tycon; family axioms are all at role N. - -Note [CoAxiom locations] -~~~~~~~~~~~~~~~~~~~~~~~~ -The source location of a CoAxiom is stored in two places in the -datatype tree. - * The first is in the location info buried in the Name of the - CoAxiom. This span includes all of the branches of a branched - CoAxiom. - * The second is in the cab_loc fields of the CoAxBranches. - -In the case of a single branch, we can extract the source location of -the branch from the name of the CoAxiom. In other cases, we need an -explicit SrcSpan to correctly store the location of the equation -giving rise to the FamInstBranch. - -Note [Implicit axioms] -~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Implicit TyThings] in GHC.Driver.Types -* A CoAxiom arising from data/type family instances is not "implicit". - That is, it has its own IfaceAxiom declaration in an interface file - -* The CoAxiom arising from a newtype declaration *is* "implicit". - That is, it does not have its own IfaceAxiom declaration in an - interface file; instead the CoAxiom is generated by type-checking - the newtype declaration - -Note [Eta reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family T a b :: * - newtype instance T Int a = MkT (IO a) deriving( Monad ) -We'd like this to work. - -From the 'newtype instance' you might think we'd get: - newtype TInt a = MkT (IO a) - axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part - axiom ax2 a :: TInt a ~ IO a -- The newtype part - -But now what can we do? We have this problem - Given: d :: Monad IO - Wanted: d' :: Monad (T Int) = d |> ???? -What coercion can we use for the ??? - -Solution: eta-reduce both axioms, thus: - axiom ax1 :: T Int ~ TInt - axiom ax2 :: TInt ~ IO -Now - d' = d |> Monad (sym (ax2 ; ax1)) - ------ Bottom line ------ - -For a CoAxBranch for a data family instance with representation -TyCon rep_tc: - - - cab_tvs (of its CoAxiom) may be shorter - than tyConTyVars of rep_tc. - - - cab_lhs may be shorter than tyConArity of the family tycon - i.e. LHS is unsaturated - - - cab_rhs will be (rep_tc cab_tvs) - i.e. RHS is un-saturated - - - This eta reduction happens for data instances as well - as newtype instances. Here we want to eta-reduce the data family axiom. - - - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. - -But for a /type/ family - - cab_lhs has the exact arity of the family tycon - -There are certain situations (e.g., pretty-printing) where it is necessary to -deal with eta-expanded data family instances. For these situations, the -cab_eta_tvs field records the stuff that has been eta-reduced away. -So if we have - axiom forall a b. F [a->b] = D b a -and cab_eta_tvs is [p,q], then the original user-written definition -looked like - axiom forall a b p q. F [a->b] p q = D b a p q -(See #9692, #14179, and #15845 for examples of what can go wrong if -we don't eta-expand when showing things to the user.) - -(See also Note [Newtype eta] in TyCon. This is notionally separate -and deals with the axiom connecting a newtype with its representation -type; but it too is eta-reduced.) --} - -instance Eq (CoAxiom br) where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable (CoAxiom br) where - getUnique = co_ax_unique - -instance Outputable (CoAxiom br) where - ppr = ppr . getName - -instance NamedThing (CoAxiom br) where - getName = co_ax_name - -instance Typeable br => Data.Data (CoAxiom br) where - -- don't traverse? - toConstr _ = abstractConstr "CoAxiom" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoAxiom" - -instance Outputable CoAxBranch where - ppr (CoAxBranch { cab_loc = loc - , cab_lhs = lhs - , cab_rhs = rhs }) = - text "CoAxBranch" <+> parens (ppr loc) <> colon - <+> brackets (fsep (punctuate comma (map pprType lhs))) - <+> text "=>" <+> pprType rhs - -{- -************************************************************************ -* * - Roles -* * -************************************************************************ - -Roles are defined here to avoid circular dependencies. --} - --- See Note [Roles] in Coercion --- defined here to avoid cyclic dependency with Coercion --- --- Order of constructors matters: the Ord instance coincides with the *super*typing --- relation on roles. -data Role = Nominal | Representational | Phantom - deriving (Eq, Ord, Data.Data) - --- These names are slurped into the parser code. Changing these strings --- will change the **surface syntax** that GHC accepts! If you want to --- change only the pretty-printing, do some replumbing. See --- mkRoleAnnotDecl in RdrHsSyn -fsFromRole :: Role -> FastString -fsFromRole Nominal = fsLit "nominal" -fsFromRole Representational = fsLit "representational" -fsFromRole Phantom = fsLit "phantom" - -instance Outputable Role where - ppr = ftext . fsFromRole - -instance Binary Role where - put_ bh Nominal = putByte bh 1 - put_ bh Representational = putByte bh 2 - put_ bh Phantom = putByte bh 3 - - get bh = do tag <- getByte bh - case tag of 1 -> return Nominal - 2 -> return Representational - 3 -> return Phantom - _ -> panic ("get Role " ++ show tag) - -{- -************************************************************************ -* * - CoAxiomRule - Rules for building Evidence -* * -************************************************************************ - -Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: - - forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 - -My intention is to reuse these for both (~) and (~#). -The short-term plan is to use this datatype to represent the type-nat axioms. -In the longer run, it may be good to unify this and `CoAxiom`, -as `CoAxiom` is the special case when there are no assumptions. --} - --- | A more explicit representation for `t1 ~ t2`. -type TypeEqn = Pair Type - --- | For now, we work only with nominal equality. -data CoAxiomRule = CoAxiomRule - { coaxrName :: FastString - , coaxrAsmpRoles :: [Role] -- roles of parameter equations - , coaxrRole :: Role -- role of resulting equation - , coaxrProves :: [TypeEqn] -> Maybe TypeEqn - -- ^ coaxrProves returns @Nothing@ when it doesn't like - -- the supplied arguments. When this happens in a coercion - -- that means that the coercion is ill-formed, and Core Lint - -- checks for that. - } - -instance Data.Data CoAxiomRule where - -- don't traverse? - toConstr _ = abstractConstr "CoAxiomRule" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoAxiomRule" - -instance Uniquable CoAxiomRule where - getUnique = getUnique . coaxrName - -instance Eq CoAxiomRule where - x == y = coaxrName x == coaxrName y - -instance Ord CoAxiomRule where - compare x y = compare (coaxrName x) (coaxrName y) - -instance Outputable CoAxiomRule where - ppr = ppr . coaxrName - - --- Type checking of built-in families -data BuiltInSynFamily = BuiltInSynFamily - { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) - , sfInteractTop :: [Type] -> Type -> [TypeEqn] - , sfInteractInert :: [Type] -> Type -> - [Type] -> Type -> [TypeEqn] - } - --- Provides default implementations that do nothing. -trivialBuiltInFamily :: BuiltInSynFamily -trivialBuiltInFamily = BuiltInSynFamily - { sfMatchFam = \_ -> Nothing - , sfInteractTop = \_ _ -> [] - , sfInteractInert = \_ _ _ _ -> [] - } diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs deleted file mode 100644 --- a/compiler/types/Coercion.hs +++ /dev/null @@ -1,2905 +0,0 @@ -{- -(c) The University of Glasgow 2006 --} - -{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, - ScopedTypeVariables #-} - --- | Module for (a) type kinds and (b) type coercions, --- as used in System FC. See 'GHC.Core.Expr' for --- more on System FC and how coercions fit into it. --- -module Coercion ( - -- * Main data type - Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, - UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, - LeftOrRight(..), - Var, CoVar, TyCoVar, - Role(..), ltRole, - - -- ** Functions over coercions - coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, - coercionType, mkCoercionType, - coercionKind, coercionLKind, coercionRKind,coercionKinds, - coercionRole, coercionKindRole, - - -- ** Constructing coercions - mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, - mkCoVarCo, mkCoVarCos, - mkAxInstCo, mkUnbranchedAxInstCo, - mkAxInstRHS, mkUnbranchedAxInstRHS, - mkAxInstLHS, mkUnbranchedAxInstLHS, - mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkTransMCo, - mkNthCo, nthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, - mkForAllCo, mkForAllCos, mkHomoForAllCos, - mkPhantomCo, - mkHoleCo, mkUnivCo, mkSubCo, - mkAxiomInstCo, mkProofIrrelCo, - downgradeRole, mkAxiomRuleCo, - mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, - mkKindCo, castCoercionKind, castCoercionKindI, - - mkHeteroCoercionType, - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, - - -- ** Decomposition - instNewTyCon_maybe, - - NormaliseStepper, NormaliseStepResult(..), composeSteppers, - mapStepResult, unwrapNewTypeStepper, - topNormaliseNewType_maybe, topNormaliseTypeX, - - decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, - splitTyConAppCo_maybe, - splitAppCo_maybe, - splitFunCo_maybe, - splitForAllCo_maybe, - splitForAllCo_ty_maybe, splitForAllCo_co_maybe, - - nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, - - pickLR, - - isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, - isReflCoVar_maybe, isGReflMCo, coToMCo, - - -- ** Coercion variables - mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, - isCoVar_maybe, - - -- ** Free variables - tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, - tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, - coercionSize, - - -- ** Substitution - CvSubstEnv, emptyCvSubstEnv, - lookupCoVar, - substCo, substCos, substCoVar, substCoVars, substCoWith, - substCoVarBndr, - extendTvSubstAndInScope, getCvSubstEnv, - - -- ** Lifting - liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, - emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, - liftCoSubstVarBndrUsing, isMappedByLC, - - mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, - - LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, - substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, - - -- ** Comparison - eqCoercion, eqCoercionX, - - -- ** Forcing evaluation of coercions - seqCo, - - -- * Pretty-printing - pprCo, pprParendCo, - pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, - pprCoAxBranchUser, tidyCoAxBndrsForUser, - etaExpandCoAxBranch, - - -- * Tidying - tidyCo, tidyCos, - - -- * Other - promoteCoercion, buildCoercion, - - simplifyArgsWorker - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) - -import GhcPrelude - -import GHC.Iface.Type -import TyCoRep -import TyCoFVs -import TyCoPpr -import TyCoSubst -import TyCoTidy -import Type -import TyCon -import CoAxiom -import Var -import VarEnv -import VarSet -import Name hiding ( varName ) -import Util -import BasicTypes -import Outputable -import Unique -import Pair -import SrcLoc -import PrelNames -import TysPrim -import ListSetOps -import Maybes -import UniqFM - -import Control.Monad (foldM, zipWithM) -import Data.Function ( on ) -import Data.Char( isDigit ) - -{- -%************************************************************************ -%* * - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. See - -- See [Coercion axioms applied to coercions] in TyCoRep - -\subsection{Coercion variables} -%* * -%************************************************************************ --} - -coVarName :: CoVar -> Name -coVarName = varName - -setCoVarUnique :: CoVar -> Unique -> CoVar -setCoVarUnique = setVarUnique - -setCoVarName :: CoVar -> Name -> CoVar -setCoVarName = setVarName - -{- -%************************************************************************ -%* * - Pretty-printing CoAxioms -%* * -%************************************************************************ - -Defined here to avoid module loops. CoAxiom is loaded very early on. - --} - -etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) --- Return the (tvs,lhs,rhs) after eta-expanding, --- to the way in which the axiom was originally written --- See Note [Eta reduction for data families] in CoAxiom -etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- ToDo: what about eta_cvs? - = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) - where - eta_tys = mkTyVarTys eta_tvs - -pprCoAxiom :: CoAxiom br -> SDoc --- Used in debug-printing only -pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = hang (text "axiom" <+> ppr ax <+> dcolon) - 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) - -pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc --- Used when printing injectivity errors (FamInst.reportInjectivityErrors) --- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) --- This happens in error messages: don't print the RHS of a data --- family axiom, which is meaningless to a user -pprCoAxBranchUser tc br - | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br - | otherwise = pprCoAxBranch tc br - -pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc --- Print the family-instance equation when reporting --- a conflict between equations (FamInst.conflictInstErr) --- For type families the RHS is important; for data families not so. --- Indeed for data families the RHS is a mysterious internal --- type constructor, so we suppress it (#14179) --- See FamInstEnv Note [Family instance overlap conflicts] -pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs - where - pp_rhs _ _ = empty - -pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc -pprCoAxBranch = ppr_co_ax_branch ppr_rhs - where - ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs - -ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) - -> TyCon -> CoAxBranch -> SDoc -ppr_co_ax_branch ppr_rhs fam_tc branch - = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') - -- See Note [Printing foralls in type family instances] in GHC.Iface.Type - , pp_lhs <+> ppr_rhs tidy_env ee_rhs - , text "-- Defined" <+> pp_loc ] - where - loc = coAxBranchSpan branch - pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) - | otherwise = text "in" <+> ppr loc - - -- Eta-expand LHS and RHS types, because sometimes data family - -- instances are eta-reduced. - -- See Note [Eta reduction for data families] in FamInstEnv. - (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch - - pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) - (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) - - (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs - -tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) --- Tidy wildcards "_1", "_2" to "_", and do not return them --- in the list of binders to be printed --- This is so that in error messages we see --- forall a. F _ [a] _ = ... --- rather than --- forall a _1 _2. F _1 [a] _2 = ... --- --- This is a rather disgusting function -tidyCoAxBndrsForUser init_env tcvs - = (tidy_env, reverse tidy_bndrs) - where - (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs - - tidy_one (env@(occ_env, subst), rev_bndrs') bndr - | is_wildcard bndr = (env_wild, rev_bndrs') - | otherwise = (env', bndr' : rev_bndrs') - where - (env', bndr') = tidyVarBndr env bndr - env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) - wild_bndr = setVarName bndr $ - tidyNameOcc (varName bndr) (mkTyVarOcc "_") - -- Tidy the binder to "_" - - is_wildcard :: Var -> Bool - is_wildcard tv = case occNameString (getOccName tv) of - ('_' : rest) -> all isDigit rest - _ -> False - -{- -%************************************************************************ -%* * - Destructing coercions -%* * -%************************************************************************ - -Note [Function coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Remember that - (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep - -Hence - FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) -is short for - TyConAppCo (->) co_rep1 co_rep2 co1 co2 -where co_rep1, co_rep2 are the coercions on the representations. --} - - --- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into --- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: --- --- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] -decomposeCo :: Arity -> Coercion - -> [Role] -- the roles of the output coercions - -- this must have at least as many - -- entries as the Arity provided - -> [Coercion] -decomposeCo arity co rs - = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] - -- Remember, Nth is zero-indexed - -decomposeFunCo :: HasDebugCallStack - => Role -- Role of the input coercion - -> Coercion -- Input coercion - -> (Coercion, Coercion) --- Expects co :: (s1 -> t1) ~ (s2 -> t2) --- Returns (co1 :: s1~s2, co2 :: t1~t2) --- See Note [Function coercions] for the "2" and "3" -decomposeFunCo r co = ASSERT2( all_ok, ppr co ) - (mkNthCo r 2 co, mkNthCo r 3 co) - where - Pair s1t1 s2t2 = coercionKind co - all_ok = isFunTy s1t1 && isFunTy s2t2 - -{- Note [Pushing a coercion into a pi-type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have this: - (f |> co) t1 .. tn -Then we want to push the coercion into the arguments, so as to make -progress. For example of why you might want to do so, see Note -[Respecting definitional equality] in TyCoRep. - -This is done by decomposePiCos. Specifically, if - decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) -then - (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn - -Notes: - -* k can be smaller than n! That is decomposePiCos can return *fewer* - coercions than there are arguments (ie k < n), if the kind provided - doesn't have enough binders. - -* If there is a type error, we might see - (f |> co) t1 - where co :: (forall a. ty) ~ (ty1 -> ty2) - Here 'co' is insoluble, but we don't want to crash in decoposePiCos. - So decomposePiCos carefully tests both sides of the coercion to check - they are both foralls or both arrows. Not doing this caused #15343. --} - -decomposePiCos :: HasDebugCallStack - => CoercionN -> Pair Type -- Coercion and its kind - -> [Type] - -> ([CoercionN], CoercionN) --- See Note [Pushing a coercion into a pi-type] -decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args - = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args - where - orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co - - go :: [CoercionN] -- accumulator for argument coercions, reversed - -> (TCvSubst,Kind) -- Lhs kind of coercion - -> CoercionN -- coercion originally applied to the function - -> (TCvSubst,Kind) -- Rhs kind of coercion - -> [Type] -- Arguments to that function - -> ([CoercionN], Coercion) - -- Invariant: co :: subst1(k2) ~ subst2(k2) - - go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) - | Just (a, t1) <- splitForAllTy_maybe k1 - , Just (b, t2) <- splitForAllTy_maybe k2 - -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) - -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) - -- a :: s1 - -- b :: s2 - -- ty :: s2 - -- need arg_co :: s2 ~ s1 - -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] - = let arg_co = mkNthCo Nominal 0 (mkSymCo co) - res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) - subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) - subst2' = extendTCvSubst subst2 b ty - in - go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys - - | Just (_s1, t1) <- splitFunTy_maybe k1 - , Just (_s2, t2) <- splitFunTy_maybe k2 - -- know co :: (s1 -> t1) ~ (s2 -> t2) - -- function :: s1 -> t1 - -- ty :: s2 - -- need arg_co :: s2 ~ s1 - -- res_co :: t1 ~ t2 - = let (sym_arg_co, res_co) = decomposeFunCo Nominal co - arg_co = mkSymCo sym_arg_co - in - go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys - - | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) - = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) - co - (zapTCvSubst subst2, substTy subst1 k2) - (ty:tys) - - -- tys might not be empty, if the left-hand type of the original coercion - -- didn't have enough binders - go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) - --- | Attempts to obtain the type variable underlying a 'Coercion' -getCoVar_maybe :: Coercion -> Maybe CoVar -getCoVar_maybe (CoVarCo cv) = Just cv -getCoVar_maybe _ = Nothing - --- | Attempts to tease a coercion apart into a type constructor and the application --- of a number of coercion arguments to that constructor -splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) -splitTyConAppCo_maybe co - | Just (ty, r) <- isReflCo_maybe co - = do { (tc, tys) <- splitTyConApp_maybe ty - ; let args = zipWith mkReflCo (tyConRolesX r tc) tys - ; return (tc, args) } -splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) -splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) - where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] -splitTyConAppCo_maybe _ = Nothing - --- first result has role equal to input; third result is Nominal -splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) --- ^ Attempt to take a coercion application apart. -splitAppCo_maybe (AppCo co arg) = Just (co, arg) -splitAppCo_maybe (TyConAppCo r tc args) - | args `lengthExceeds` tyConArity tc - , Just (args', arg') <- snocView args - = Just ( mkTyConAppCo r tc args', arg' ) - - | not (mustBeSaturated tc) - -- Never create unsaturated type family apps! - , Just (args', arg') <- snocView args - , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' - = Just ( mkTyConAppCo r tc args', arg'' ) - -- Use mkTyConAppCo to preserve the invariant - -- that identity coercions are always represented by Refl - -splitAppCo_maybe co - | Just (ty, r) <- isReflCo_maybe co - , Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (mkReflCo r ty1, mkNomReflCo ty2) -splitAppCo_maybe _ = Nothing - -splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) -splitFunCo_maybe _ = Nothing - -splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) -splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) -splitForAllCo_maybe _ = Nothing - --- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder -splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) -splitForAllCo_ty_maybe (ForAllCo tv k_co co) - | isTyVar tv = Just (tv, k_co, co) -splitForAllCo_ty_maybe _ = Nothing - --- | Like 'splitForAllCo_maybe', but only returns Just for covar binder -splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) -splitForAllCo_co_maybe (ForAllCo cv k_co co) - | isCoVar cv = Just (cv, k_co, co) -splitForAllCo_co_maybe _ = Nothing - -------------------------------------------------------- --- and some coercion kind stuff - -coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type -coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1 -coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2 - -coVarTypes :: HasDebugCallStack => CoVar -> Pair Type -coVarTypes cv - | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv - = Pair ty1 ty2 - -coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) -coVarKindsTypesRole cv - | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = (k1, k2, ty1, ty2, eqTyConRole tc) - | otherwise - = pprPanic "coVarKindsTypesRole, non coercion variable" - (ppr cv $$ ppr (varType cv)) - -coVarKind :: CoVar -> Type -coVarKind cv - = ASSERT( isCoVar cv ) - varType cv - -coVarRole :: CoVar -> Role -coVarRole cv - = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of - Just tc0 -> tc0 - Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) - -eqTyConRole :: TyCon -> Role --- Given (~#) or (~R#) return the Nominal or Representational respectively -eqTyConRole tc - | tc `hasKey` eqPrimTyConKey - = Nominal - | tc `hasKey` eqReprPrimTyConKey - = Representational - | otherwise - = pprPanic "eqTyConRole: unknown tycon" (ppr tc) - --- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, --- produce a coercion @rep_co :: r1 ~ r2@. -mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion -mkRuntimeRepCo co - = mkNthCo Nominal 0 kind_co - where - kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 - -- (up to silliness with Constraint) - -isReflCoVar_maybe :: Var -> Maybe Coercion --- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) --- Works on all kinds of Vars, not just CoVars -isReflCoVar_maybe cv - | isCoVar cv - , Pair ty1 ty2 <- coVarTypes cv - , ty1 `eqType` ty2 - = Just (mkReflCo (coVarRole cv) ty1) - | otherwise - = Nothing - --- | Tests if this coercion is obviously a generalized reflexive coercion. --- Guaranteed to work very quickly. -isGReflCo :: Coercion -> Bool -isGReflCo (GRefl{}) = True -isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl -isGReflCo _ = False - --- | Tests if this MCoercion is obviously generalized reflexive --- Guaranteed to work very quickly. -isGReflMCo :: MCoercion -> Bool -isGReflMCo MRefl = True -isGReflMCo (MCo co) | isGReflCo co = True -isGReflMCo _ = False - --- | Tests if this coercion is obviously reflexive. Guaranteed to work --- very quickly. Sometimes a coercion can be reflexive, but not obviously --- so. c.f. 'isReflexiveCo' -isReflCo :: Coercion -> Bool -isReflCo (Refl{}) = True -isReflCo (GRefl _ _ mco) | isGReflMCo mco = True -isReflCo _ = False - --- | Returns the type coerced if this coercion is a generalized reflexive --- coercion. Guaranteed to work very quickly. -isGReflCo_maybe :: Coercion -> Maybe (Type, Role) -isGReflCo_maybe (GRefl r ty _) = Just (ty, r) -isGReflCo_maybe (Refl ty) = Just (ty, Nominal) -isGReflCo_maybe _ = Nothing - --- | Returns the type coerced if this coercion is reflexive. Guaranteed --- to work very quickly. Sometimes a coercion can be reflexive, but not --- obviously so. c.f. 'isReflexiveCo_maybe' -isReflCo_maybe :: Coercion -> Maybe (Type, Role) -isReflCo_maybe (Refl ty) = Just (ty, Nominal) -isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) -isReflCo_maybe _ = Nothing - --- | Slowly checks if the coercion is reflexive. Don't call this in a loop, --- as it walks over the entire coercion. -isReflexiveCo :: Coercion -> Bool -isReflexiveCo = isJust . isReflexiveCo_maybe - --- | Extracts the coerced type from a reflexive coercion. This potentially --- walks over the entire coercion, so avoid doing this in a loop. -isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) -isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) -isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) -isReflexiveCo_maybe co - | ty1 `eqType` ty2 - = Just (ty1, r) - | otherwise - = Nothing - where (Pair ty1 ty2, r) = coercionKindRole co - -coToMCo :: Coercion -> MCoercion -coToMCo c = if isReflCo c - then MRefl - else MCo c - -{- -%************************************************************************ -%* * - Building coercions -%* * -%************************************************************************ - -These "smart constructors" maintain the invariants listed in the definition -of Coercion, and they perform very basic optimizations. - -Note [Role twiddling functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a plethora of functions for twiddling roles: - -mkSubCo: Requires a nominal input coercion and always produces a -representational output. This is used when you (the programmer) are sure you -know exactly that role you have and what you want. - -downgradeRole_maybe: This function takes both the input role and the output role -as parameters. (The *output* role comes first!) It can only *downgrade* a -role -- that is, change it from N to R or P, or from R to P. This one-way -behavior is why there is the "_maybe". If an upgrade is requested, this -function produces Nothing. This is used when you need to change the role of a -coercion, but you're not sure (as you're writing the code) of which roles are -involved. - -This function could have been written using coercionRole to ascertain the role -of the input. But, that function is recursive, and the caller of downgradeRole_maybe -often knows the input role. So, this is more efficient. - -downgradeRole: This is just like downgradeRole_maybe, but it panics if the -conversion isn't a downgrade. - -setNominalRole_maybe: This is the only function that can *upgrade* a coercion. -The result (if it exists) is always Nominal. The input can be at any role. It -works on a "best effort" basis, as it should never be strictly necessary to -upgrade a coercion during compilation. It is currently only used within GHC in -splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second -coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable -that splitAppCo_maybe is operating over a TyConAppCo that uses a -representational coercion. Hence the need for setNominalRole_maybe. -splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, -it is not absolutely critical that setNominalRole_maybe be complete. - -Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom -UnivCos are perfectly type-safe, whereas representational and nominal ones are -not. (Nominal ones are no worse than representational ones, so this function *will* -change a UnivCo Representational to a UnivCo Nominal.) - -Conal Elliott also came across a need for this function while working with the -GHC API, as he was decomposing Core casts. The Core casts use representational -coercions, as they must, but his use case required nominal coercions (he was -building a GADT). So, that's why this function is exported from this module. - -One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as -appropriate? I (Richard E.) have decided not to do this, because upgrading a -role is bizarre and a caller should have to ask for this behavior explicitly. - --} - --- | Make a generalized reflexive coercion -mkGReflCo :: Role -> Type -> MCoercionN -> Coercion -mkGReflCo r ty mco - | isGReflMCo mco = if r == Nominal then Refl ty - else GRefl r ty MRefl - | otherwise = GRefl r ty mco - --- | Make a reflexive coercion -mkReflCo :: Role -> Type -> Coercion -mkReflCo Nominal ty = Refl ty -mkReflCo r ty = GRefl r ty MRefl - --- | Make a representational reflexive coercion -mkRepReflCo :: Type -> Coercion -mkRepReflCo ty = GRefl Representational ty MRefl - --- | Make a nominal reflexive coercion -mkNomReflCo :: Type -> Coercion -mkNomReflCo = Refl - --- | Apply a type constructor to a list of coercions. It is the --- caller's responsibility to get the roles correct on argument coercions. -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkTyConAppCo r tc cos - | tc `hasKey` funTyConKey - , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] - = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) - -- rep1 :: ra ~ rc rep2 :: rb ~ rd - -- co1 :: a ~ c co2 :: b ~ d - mkFunCo r co1 co2 - - -- Expand type synonyms - | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos - = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - - | Just tys_roles <- traverse isReflCo_maybe cos - = mkReflCo r (mkTyConApp tc (map fst tys_roles)) - -- See Note [Refl invariant] - - | otherwise = TyConAppCo r tc cos - --- | Build a function 'Coercion' from two other 'Coercion's. That is, --- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkFunCo r co1 co2 - -- See Note [Refl invariant] - | Just (ty1, _) <- isReflCo_maybe co1 - , Just (ty2, _) <- isReflCo_maybe co2 - = mkReflCo r (mkVisFunTy ty1 ty2) - | otherwise = FunCo r co1 co2 - --- | Apply a 'Coercion' to another 'Coercion'. --- The second coercion must be Nominal, unless the first is Phantom. --- If the first is Phantom, then the second can be either Phantom or Nominal. -mkAppCo :: Coercion -- ^ :: t1 ~r t2 - -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 - -> Coercion -- ^ :: t1 s1 ~r t2 s2 -mkAppCo co arg - | Just (ty1, r) <- isReflCo_maybe co - , Just (ty2, _) <- isReflCo_maybe arg - = mkReflCo r (mkAppTy ty1 ty2) - - | Just (ty1, r) <- isReflCo_maybe co - , Just (tc, tys) <- splitTyConApp_maybe ty1 - -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) - = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) - where - zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... - -mkAppCo (TyConAppCo r tc args) arg - = case r of - Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) - Representational -> mkTyConAppCo Representational tc (args ++ [arg']) - where new_role = (tyConRolesRepresentational tc) !! (length args) - arg' = downgradeRole new_role Nominal arg - Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) -mkAppCo co arg = AppCo co arg --- Note, mkAppCo is careful to maintain invariants regarding --- where Refl constructors appear; see the comments in the definition --- of Coercion and the Note [Refl invariant] in TyCoRep. - --- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCo'. -mkAppCos :: Coercion - -> [Coercion] - -> Coercion -mkAppCos co1 cos = foldl' mkAppCo co1 cos - -{- Note [Unused coercion variable in ForAllCo] - -See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for -checking coercion variable in types. -To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: - -(1) In mkForAllCo, we check whether cv is a coercion variable - and whether it is not used in body_co. If so we construct a FunCo. -(2) We don't do this check in mkForAllCo. - In coercionKind, we use mkTyCoForAllTy to perform the check and construct - a FunTy when necessary. - -We chose (2) for two reasons: - -* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not - make a difference. -* even if cv occurs in body_co, it is possible that cv does not occur in the kind - of body_co. Therefore the check in coercionKind is inevitable. - -The last wrinkle is that there are restrictions around the use of the cv in the -coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that -we cannot prove that the type system is consistent with unrestricted use of this -cv; the consistency proof uses an untyped rewrite relation that works over types -with all coercions and casts removed. So, we can allow the cv to appear only in -positions that are erased. As an approximation of this (and keeping close to the -published theory), we currently allow the cv only within the type in a Refl node -and under a GRefl node (including in the Coercion stored in a GRefl). It's -possible other places are OK, too, but this is a safe approximation. - -Sadly, with heterogeneous equality, this restriction might be able to be violated; -Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst -function might create an invalid coercion. Because a violation of the -restriction might lead to a program that "goes wrong", it is checked all the time, -even in a production compiler and without -dcore-list. We *have* proved that the -problem does not occur with homogeneous equality, so this check can be dropped -once ~# is made to be homogeneous. --} - - --- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. --- The kind of the tycovar should be the left-hand kind of the kind coercion. --- See Note [Unused coercion variable in ForAllCo] -mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion -mkForAllCo v kind_co co - | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True - , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True - , Just (ty, r) <- isReflCo_maybe co - , isGReflCo kind_co - = mkReflCo r (mkTyCoInvForAllTy v ty) - | otherwise - = ForAllCo v kind_co co - --- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious --- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. --- The kind of the tycovar should be the left-hand kind of the kind coercion. -mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion -mkForAllCo_NoRefl v kind_co co - | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True - , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True - , ASSERT( not (isReflCo co)) True - , isCoVar v - , not (v `elemVarSet` tyCoVarsOfCo co) - = FunCo (coercionRole co) kind_co co - | otherwise - = ForAllCo v kind_co co - --- | Make nested ForAllCos -mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion -mkForAllCos bndrs co - | Just (ty, r ) <- isReflCo_maybe co - = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in - foldl' (flip $ uncurry mkForAllCo_NoRefl) - (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) - non_refls_rev'd - | otherwise - = foldr (uncurry mkForAllCo_NoRefl) co bndrs - --- | Make a Coercion quantified over a type/coercion variable; --- the variable has the same type in both sides of the coercion -mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion -mkHomoForAllCos vs co - | Just (ty, r) <- isReflCo_maybe co - = mkReflCo r (mkTyCoInvForAllTys vs ty) - | otherwise - = mkHomoForAllCos_NoRefl vs co - --- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious --- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. -mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion -mkHomoForAllCos_NoRefl vs orig_co - = ASSERT( not (isReflCo orig_co)) - foldr go orig_co vs - where - go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co - -mkCoVarCo :: CoVar -> Coercion --- cv :: s ~# t --- See Note [mkCoVarCo] -mkCoVarCo cv = CoVarCo cv - -mkCoVarCos :: [CoVar] -> [Coercion] -mkCoVarCos = map mkCoVarCo - -{- Note [mkCoVarCo] -~~~~~~~~~~~~~~~~~~~ -In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is -valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but -it's a relatively expensive test and perhaps better done in -optCoercion. Not a big deal either way. --} - --- | Extract a covar, if possible. This check is dirty. Be ashamed --- of yourself. (It's dirty because it cares about the structure of --- a coercion, which is morally reprehensible.) -isCoVar_maybe :: Coercion -> Maybe CoVar -isCoVar_maybe (CoVarCo cv) = Just cv -isCoVar_maybe _ = Nothing - -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] - -> Coercion --- mkAxInstCo can legitimately be called over-staturated; --- i.e. with more type arguments than the coercion requires -mkAxInstCo role ax index tys cos - | arity == n_tys = downgradeRole role ax_role $ - mkAxiomInstCo ax_br index (rtys `chkAppend` cos) - | otherwise = ASSERT( arity < n_tys ) - downgradeRole role ax_role $ - mkAppCos (mkAxiomInstCo ax_br index - (ax_args `chkAppend` cos)) - leftover_args - where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - tvs = coAxBranchTyVars branch - arity = length tvs - arg_roles = coAxBranchRoles branch - rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys - (ax_args, leftover_args) - = splitAt arity rtys - ax_role = coAxiomRole ax - --- worker function -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkAxiomInstCo ax index args - = ASSERT( args `lengthIs` coAxiomArity ax index ) - AxiomInstCo ax index args - --- to be used only with unbranched axioms -mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched - -> [Type] -> [Coercion] -> Coercion -mkUnbranchedAxInstCo role ax tys cos - = mkAxInstCo role ax 0 tys cos - -mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type --- Instantiate the axiom with specified types, --- returning the instantiated RHS --- A companion to mkAxInstCo: --- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) -mkAxInstRHS ax index tys cos - = ASSERT( tvs `equalLength` tys1 ) - mkAppTys rhs' tys2 - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - rhs' = substTyWith tvs tys1 $ - substTyWithCoVars cvs cos $ - coAxBranchRHS branch - -mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 - --- | Return the left-hand type of the axiom, when the axiom is instantiated --- at the types given. -mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type -mkAxInstLHS ax index tys cos - = ASSERT( tvs `equalLength` tys1 ) - mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - lhs_tys = substTysWith tvs tys1 $ - substTysWithCoVars cvs cos $ - coAxBranchLHS branch - fam_tc = coAxiomTyCon ax - --- | Instantiate the left-hand side of an unbranched axiom -mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 - --- | Make a coercion from a coercion hole -mkHoleCo :: CoercionHole -> Coercion -mkHoleCo h = HoleCo h - --- | Make a universal coercion between two arbitrary types. -mkUnivCo :: UnivCoProvenance - -> Role -- ^ role of the built coercion, "r" - -> Type -- ^ t1 :: k1 - -> Type -- ^ t2 :: k2 - -> Coercion -- ^ :: t1 ~r t2 -mkUnivCo prov role ty1 ty2 - | ty1 `eqType` ty2 = mkReflCo role ty1 - | otherwise = UnivCo prov role ty1 ty2 - --- | Create a symmetric version of the given 'Coercion' that asserts --- equality between the same types but in the other "direction", so --- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. -mkSymCo :: Coercion -> Coercion - --- Do a few simple optimizations, but don't bother pushing occurrences --- of symmetry to the leaves; the optimizer will take care of that. -mkSymCo co | isReflCo co = co -mkSymCo (SymCo co) = co -mkSymCo (SubCo (SymCo co)) = SubCo co -mkSymCo co = SymCo co - --- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. --- (co1 ; co2) -mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo co1 co2 | isReflCo co1 = co2 - | isReflCo co2 = co1 -mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) - = GRefl r t1 (MCo $ mkTransCo co1 co2) -mkTransCo co1 co2 = TransCo co1 co2 - --- | Compose two MCoercions via transitivity -mkTransMCo :: MCoercion -> MCoercion -> MCoercion -mkTransMCo MRefl co2 = co2 -mkTransMCo co1 MRefl = co1 -mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) - -mkNthCo :: HasDebugCallStack - => Role -- The role of the coercion you're creating - -> Int -- Zero-indexed - -> Coercion - -> Coercion -mkNthCo r n co - = ASSERT2( good_call, bad_call_msg ) - go r n co - where - Pair ty1 ty2 = coercionKind co - - go r 0 co - | Just (ty, _) <- isReflCo_maybe co - , Just (tv, _) <- splitForAllTy_maybe ty - = -- works for both tyvar and covar - ASSERT( r == Nominal ) - mkNomReflCo (varType tv) - - go r n co - | Just (ty, r0) <- isReflCo_maybe co - , let tc = tyConAppTyCon ty - = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) - ASSERT( nthRole r0 tc n == r ) - mkReflCo r (tyConAppArgN n ty) - where ok_tc_app :: Type -> Int -> Bool - ok_tc_app ty n - | Just (_, tys) <- splitTyConApp_maybe ty - = tys `lengthExceeds` n - | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall - = n == 0 - | otherwise - = False - - go r 0 (ForAllCo _ kind_co _) - = ASSERT( r == Nominal ) - kind_co - -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) - -- then (nth 0 co :: k1 ~N k2) - -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) - -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) - - go r n co@(FunCo r0 arg res) - -- See Note [Function coercions] - -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) - -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) - -- Then we want to behave as if co was - -- TyConAppCo argk_co resk_co arg_co res_co - -- where - -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) - -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) - -- i.e. mkRuntimeRepCo - = case n of - 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg - 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res - 2 -> ASSERT( r == r0 ) arg - 3 -> ASSERT( r == r0 ) res - _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) - - go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n - , (vcat [ ppr tc - , ppr arg_cos - , ppr r0 - , ppr n - , ppr r ]) ) - arg_cos `getNth` n - - go r n co = - NthCo r n co - - -- Assertion checking - bad_call_msg = vcat [ text "Coercion =" <+> ppr co - , text "LHS ty =" <+> ppr ty1 - , text "RHS ty =" <+> ppr ty2 - , text "n =" <+> ppr n, text "r =" <+> ppr r - , text "coercion role =" <+> ppr (coercionRole co) ] - good_call - -- If the Coercion passed in is between forall-types, then the Int must - -- be 0 and the role must be Nominal. - | Just (_tv1, _) <- splitForAllTy_maybe ty1 - , Just (_tv2, _) <- splitForAllTy_maybe ty2 - = n == 0 && r == Nominal - - -- If the Coercion passed in is between T tys and T tys', then the Int - -- must be less than the length of tys/tys' (which must be the same - -- lengths). - -- - -- If the role of the Coercion is nominal, then the role passed in must - -- be nominal. If the role of the Coercion is representational, then the - -- role passed in must be tyConRolesRepresentational T !! n. If the role - -- of the Coercion is Phantom, then the role passed in must be Phantom. - -- - -- See also Note [NthCo Cached Roles] if you're wondering why it's - -- blaringly obvious that we should be *computing* this role instead of - -- passing it in. - | Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - = let len1 = length tys1 - len2 = length tys2 - good_role = case coercionRole co of - Nominal -> r == Nominal - Representational -> r == (tyConRolesRepresentational tc1 !! n) - Phantom -> r == Phantom - in len1 == len2 && n < len1 && good_role - - | otherwise - = True - - - --- | If you're about to call @mkNthCo r n co@, then @r@ should be --- whatever @nthCoRole n co@ returns. -nthCoRole :: Int -> Coercion -> Role -nthCoRole n co - | Just (tc, _) <- splitTyConApp_maybe lty - = nthRole r tc n - - | Just _ <- splitForAllTy_maybe lty - = Nominal - - | otherwise - = pprPanic "nthCoRole" (ppr co) - - where - lty = coercionLKind co - r = coercionRole co - -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkLRCo lr co - | Just (ty, eq) <- isReflCo_maybe co - = mkReflCo eq (pickLR lr (splitAppTy ty)) - | otherwise - = LRCo lr co - --- | Instantiates a 'Coercion'. -mkInstCo :: Coercion -> Coercion -> Coercion -mkInstCo (ForAllCo tcv _kind_co body_co) co - | Just (arg, _) <- isReflCo_maybe co - -- works for both tyvar and covar - = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co -mkInstCo co arg = InstCo co arg - --- | Given @ty :: k1@, @co :: k1 ~ k2@, --- produces @co' :: ty ~r (ty |> co)@ -mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion -mkGReflRightCo r ty co - | isGReflCo co = mkReflCo r ty - -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ - -- instead of @isReflCo@ - | otherwise = GRefl r ty (MCo co) - --- | Given @ty :: k1@, @co :: k1 ~ k2@, --- produces @co' :: (ty |> co) ~r ty@ -mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion -mkGReflLeftCo r ty co - | isGReflCo co = mkReflCo r ty - -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ - -- instead of @isReflCo@ - | otherwise = mkSymCo $ GRefl r ty (MCo co) - --- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, --- produces @co' :: (ty |> co) ~r ty' --- It is not only a utility function, but it saves allocation when co --- is a GRefl coercion. -mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion -mkCoherenceLeftCo r ty co co2 - | isGReflCo co = co2 - | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 - --- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, --- produces @co' :: ty' ~r (ty |> co) --- It is not only a utility function, but it saves allocation when co --- is a GRefl coercion. -mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion -mkCoherenceRightCo r ty co co2 - | isGReflCo co = co2 - | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) - --- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. -mkKindCo :: Coercion -> Coercion -mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) -mkKindCo (GRefl _ _ (MCo co)) = co -mkKindCo (UnivCo (PhantomProv h) _ _ _) = h -mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h -mkKindCo co - | Pair ty1 ty2 <- coercionKind co - -- generally, calling coercionKind during coercion creation is a bad idea, - -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, - -- so it's OK here. - , let tk1 = typeKind ty1 - tk2 = typeKind ty2 - , tk1 `eqType` tk2 - = Refl tk1 - | otherwise - = KindCo co - -mkSubCo :: Coercion -> Coercion --- Input coercion is Nominal, result is Representational --- see also Note [Role twiddling functions] -mkSubCo (Refl ty) = GRefl Representational ty MRefl -mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co -mkSubCo (TyConAppCo Nominal tc cos) - = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (FunCo Nominal arg res) - = FunCo Representational - (downgradeRole Representational Nominal arg) - (downgradeRole Representational Nominal res) -mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) - SubCo co - --- | Changes a role, but only a downgrade. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- ^ desired role - -> Role -- ^ current role - -> Coercion -> Maybe Coercion --- In (downgradeRole_maybe dr cr co) it's a precondition that --- cr = coercionRole co - -downgradeRole_maybe Nominal Nominal co = Just co -downgradeRole_maybe Nominal _ _ = Nothing - -downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) -downgradeRole_maybe Representational Representational co = Just co -downgradeRole_maybe Representational Phantom _ = Nothing - -downgradeRole_maybe Phantom Phantom co = Just co -downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) - --- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. --- See Note [Role twiddling functions] -downgradeRole :: Role -- desired role - -> Role -- current role - -> Coercion -> Coercion -downgradeRole r1 r2 co - = case downgradeRole_maybe r1 r2 co of - Just co' -> co' - Nothing -> pprPanic "downgradeRole" (ppr co) - -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion -mkAxiomRuleCo = AxiomRuleCo - --- | Make a "coercion between coercions". -mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" - -> Coercion -- ^ :: phi1 ~N phi2 - -> Coercion -- ^ g1 :: phi1 - -> Coercion -- ^ g2 :: phi2 - -> Coercion -- ^ :: g1 ~r g2 - --- if the two coercion prove the same fact, I just don't care what --- the individual coercions are. -mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) - -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ -mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r - (mkCoercionTy g1) (mkCoercionTy g2) - -{- -%************************************************************************ -%* * - Roles -%* * -%************************************************************************ --} - --- | Converts a coercion to be nominal, if possible. --- See Note [Role twiddling functions] -setNominalRole_maybe :: Role -- of input coercion - -> Coercion -> Maybe Coercion -setNominalRole_maybe r co - | r == Nominal = Just co - | otherwise = setNominalRole_maybe_helper co - where - setNominalRole_maybe_helper (SubCo co) = Just co - setNominalRole_maybe_helper co@(Refl _) = Just co - setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co - setNominalRole_maybe_helper (TyConAppCo Representational tc cos) - = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos - ; return $ TyConAppCo Nominal tc cos' } - setNominalRole_maybe_helper (FunCo Representational co1 co2) - = do { co1' <- setNominalRole_maybe Representational co1 - ; co2' <- setNominalRole_maybe Representational co2 - ; return $ FunCo Nominal co1' co2' - } - setNominalRole_maybe_helper (SymCo co) - = SymCo <$> setNominalRole_maybe_helper co - setNominalRole_maybe_helper (TransCo co1 co2) - = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 - setNominalRole_maybe_helper (AppCo co1 co2) - = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 - setNominalRole_maybe_helper (ForAllCo tv kind_co co) - = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co - setNominalRole_maybe_helper (NthCo _r n co) - -- NB, this case recurses via setNominalRole_maybe, not - -- setNominalRole_maybe_helper! - = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co - setNominalRole_maybe_helper (InstCo co arg) - = InstCo <$> setNominalRole_maybe_helper co <*> pure arg - setNominalRole_maybe_helper (UnivCo prov _ co1 co2) - | case prov of PhantomProv _ -> False -- should always be phantom - ProofIrrelProv _ -> True -- it's always safe - PluginProv _ -> False -- who knows? This choice is conservative. - = Just $ UnivCo prov Nominal co1 co2 - setNominalRole_maybe_helper _ = Nothing - --- | Make a phantom coercion between two types. The coercion passed --- in must be a nominal coercion between the kinds of the --- types. -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkPhantomCo h t1 t2 - = mkUnivCo (PhantomProv h) Phantom t1 t2 - --- takes any coercion and turns it into a Phantom coercion -toPhantomCo :: Coercion -> Coercion -toPhantomCo co - = mkPhantomCo (mkKindCo co) ty1 ty2 - where Pair ty1 ty2 = coercionKind co - --- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational -applyRoles :: TyCon -> [Coercion] -> [Coercion] -applyRoles tc cos - = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos - --- the Role parameter is the Role of the TyConAppCo --- defined here because this is intimately concerned with the implementation --- of TyConAppCo --- Always returns an infinite list (with a infinite tail of Nominal) -tyConRolesX :: Role -> TyCon -> [Role] -tyConRolesX Representational tc = tyConRolesRepresentational tc -tyConRolesX role _ = repeat role - --- Returns the roles of the parameters of a tycon, with an infinite tail --- of Nominal -tyConRolesRepresentational :: TyCon -> [Role] -tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal - -nthRole :: Role -> TyCon -> Int -> Role -nthRole Nominal _ _ = Nominal -nthRole Phantom _ _ = Phantom -nthRole Representational tc n - = (tyConRolesRepresentational tc) `getNth` n - -ltRole :: Role -> Role -> Bool --- Is one role "less" than another? --- Nominal < Representational < Phantom -ltRole Phantom _ = False -ltRole Representational Phantom = True -ltRole Representational _ = False -ltRole Nominal Nominal = False -ltRole Nominal _ = True - -------------------------------- - --- | like mkKindCo, but aggressively & recursively optimizes to avoid using --- a KindCo constructor. The output role is nominal. -promoteCoercion :: Coercion -> CoercionN - --- First cases handles anything that should yield refl. -promoteCoercion co = case co of - - _ | ki1 `eqType` ki2 - -> mkNomReflCo (typeKind ty1) - -- no later branch should return refl - -- The ASSERT( False )s throughout - -- are these cases explicitly, but they should never fire. - - Refl _ -> ASSERT( False ) - mkNomReflCo ki1 - - GRefl _ _ MRefl -> ASSERT( False ) - mkNomReflCo ki1 - - GRefl _ _ (MCo co) -> co - - TyConAppCo _ tc args - | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args - -> co' - | otherwise - -> mkKindCo co - - AppCo co1 arg - | Just co' <- instCoercion (coercionKind (mkKindCo co1)) - (promoteCoercion co1) arg - -> co' - | otherwise - -> mkKindCo co - - ForAllCo tv _ g - | isTyVar tv - -> promoteCoercion g - - ForAllCo _ _ _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in Type - - FunCo _ _ _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - - CoVarCo {} -> mkKindCo co - HoleCo {} -> mkKindCo co - AxiomInstCo {} -> mkKindCo co - AxiomRuleCo {} -> mkKindCo co - - UnivCo (PhantomProv kco) _ _ _ -> kco - UnivCo (ProofIrrelProv kco) _ _ _ -> kco - UnivCo (PluginProv _) _ _ _ -> mkKindCo co - - SymCo g - -> mkSymCo (promoteCoercion g) - - TransCo co1 co2 - -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) - - NthCo _ n co1 - | Just (_, args) <- splitTyConAppCo_maybe co1 - , args `lengthExceeds` n - -> promoteCoercion (args !! n) - - | Just _ <- splitForAllCo_maybe co - , n == 0 - -> ASSERT( False ) mkNomReflCo liftedTypeKind - - | otherwise - -> mkKindCo co - - LRCo lr co1 - | Just (lco, rco) <- splitAppCo_maybe co1 - -> case lr of - CLeft -> promoteCoercion lco - CRight -> promoteCoercion rco - - | otherwise - -> mkKindCo co - - InstCo g _ - | isForAllTy_ty ty1 - -> ASSERT( isForAllTy_ty ty2 ) - promoteCoercion g - | otherwise - -> ASSERT( False) - mkNomReflCo liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in Type - - KindCo _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - - SubCo g - -> promoteCoercion g - - where - Pair ty1 ty2 = coercionKind co - ki1 = typeKind ty1 - ki2 = typeKind ty2 - --- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, --- where @g' = promoteCoercion (h w)@. --- fails if this is not possible, if @g@ coerces between a forall and an -> --- or if second parameter has a representational role and can't be used --- with an InstCo. -instCoercion :: Pair Type -- g :: lty ~ rty - -> CoercionN -- ^ must be nominal - -> Coercion - -> Maybe CoercionN -instCoercion (Pair lty rty) g w - | (isForAllTy_ty lty && isForAllTy_ty rty) - || (isForAllTy_co lty && isForAllTy_co rty) - , Just w' <- setNominalRole_maybe (coercionRole w) w - -- g :: (forall t1. t2) ~ (forall t1. t3) - -- w :: s1 ~ s2 - -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] - = Just $ mkInstCo g w' - | isFunTy lty && isFunTy rty - -- g :: (t1 -> t2) ~ (t3 -> t4) - -- returns t2 ~ t4 - = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) - | otherwise -- one forall, one funty... - = Nothing - --- | Repeated use of 'instCoercion' -instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN -instCoercions g ws - = let arg_ty_pairs = map coercionKind ws in - snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) - where - go :: (Pair Type, Coercion) -> (Pair Type, Coercion) - -> Maybe (Pair Type, Coercion) - go (g_tys, g) (w_tys, w) - = do { g' <- instCoercion g_tys g w - ; return (piResultTy <$> g_tys <*> w_tys, g') } - --- | Creates a new coercion with both of its types casted by different casts --- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, --- has type @(t1 |> h1) ~r (t2 |> h2)@. --- @h1@ and @h2@ must be nominal. -castCoercionKind :: Coercion -> Role -> Type -> Type - -> CoercionN -> CoercionN -> Coercion -castCoercionKind g r t1 t2 h1 h2 - = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) - --- | Creates a new coercion with both of its types casted by different casts --- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, --- has type @(t1 |> h1) ~r (t2 |> h2)@. --- @h1@ and @h2@ must be nominal. --- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) --- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand. -castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion -castCoercionKindI g h1 h2 - = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) - where (Pair t1 t2, r) = coercionKindRole g - --- See note [Newtype coercions] in TyCon - -mkPiCos :: Role -> [Var] -> Coercion -> Coercion -mkPiCos r vs co = foldr (mkPiCo r) co vs - --- | Make a forall 'Coercion', where both types related by the coercion --- are quantified over the same variable. -mkPiCo :: Role -> Var -> Coercion -> Coercion -mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co - | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) - -- We didn't call mkForAllCo here because if v does not appear - -- in co, the argement coercion will be nominal. But here we - -- want it to be r. It is only called in 'mkPiCos', which is - -- only used in SimplUtils, where we are sure for - -- now (Aug 2018) v won't occur in co. - mkFunCo r (mkReflCo r (varType v)) co - | otherwise = mkFunCo r (mkReflCo r (varType v)) co - --- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 --- The first coercion might be lifted or unlifted; thus the ~? above --- Lifted and unlifted equalities take different numbers of arguments, --- so we have to make sure to supply the right parameter to decomposeCo. --- Also, note that the role of the first coercion is the same as the role of --- the equalities related by the second coercion. The second coercion is --- itself always representational. -mkCoCast :: Coercion -> CoercionR -> Coercion -mkCoCast c g - | (g2:g1:_) <- reverse co_list - = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 - - | otherwise - = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) - where - -- g :: (s1 ~# t1) ~# (s2 ~# t2) - -- g1 :: s1 ~# s2 - -- g2 :: t1 ~# t2 - (tc, _) = splitTyConApp (coercionLKind g) - co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) - -{- -%************************************************************************ -%* * - Newtypes -%* * -%************************************************************************ --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated -instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) -instNewTyCon_maybe tc tys - | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype - , tvs `leLength` tys -- Check saturated enough - = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Type normalisation -* * -************************************************************************ --} - --- | A function to check if we can reduce a type by one step. Used --- with 'topNormaliseTypeX'. -type NormaliseStepper ev = RecTcChecker - -> TyCon -- tc - -> [Type] -- tys - -> NormaliseStepResult ev - --- | The result of stepping in a normalisation function. --- See 'topNormaliseTypeX'. -data NormaliseStepResult ev - = NS_Done -- ^ Nothing more to do - | NS_Abort -- ^ Utter failure. The outer function should fail too. - | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; - -- ^ ev is evidence; - -- Usually a co :: old type ~ new type - -mapStepResult :: (ev1 -> ev2) - -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 -mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) -mapStepResult _ NS_Done = NS_Done -mapStepResult _ NS_Abort = NS_Abort - --- | Try one stepper and then try the next, if the first doesn't make --- progress. --- So if it returns NS_Done, it means that both steppers are satisfied -composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev - -> NormaliseStepper ev -composeSteppers step1 step2 rec_nts tc tys - = case step1 rec_nts tc tys of - success@(NS_Step {}) -> success - NS_Done -> step2 rec_nts tc tys - NS_Abort -> NS_Abort - --- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into --- a loop. If it would fall into a loop, it produces 'NS_Abort'. -unwrapNewTypeStepper :: NormaliseStepper Coercion -unwrapNewTypeStepper rec_nts tc tys - | Just (ty', co) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' ty' co - Nothing -> NS_Abort - - | otherwise - = NS_Done - --- | A general function for normalising the top-level of a type. It continues --- to use the provided 'NormaliseStepper' until that function fails, and then --- this function returns. The roles of the coercions produced by the --- 'NormaliseStepper' must all be the same, which is the role returned from --- the call to 'topNormaliseTypeX'. --- --- Typically ev is Coercion. --- --- If topNormaliseTypeX step plus ty = Just (ev, ty') --- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' --- and ev = ev1 `plus` ev2 `plus` ... `plus` evn --- If it returns Nothing then no newtype unwrapping could happen -topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) - -> Type -> Maybe (ev, Type) -topNormaliseTypeX stepper plus ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys - = go rec_nts ev ty' - | otherwise - = Nothing - where - go rec_nts ev ty - | Just (tc, tys) <- splitTyConApp_maybe ty - = case stepper rec_nts tc tys of - NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' - NS_Done -> Just (ev, ty) - NS_Abort -> Nothing - - | otherwise - = Just (ev, ty) - -topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) --- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. --- This function strips off @newtype@ layers enough to reveal something that isn't --- a @newtype@. Specifically, here's the invariant: --- --- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') --- --- then (a) @co : ty0 ~ ty'@. --- (b) ty' is not a newtype. --- --- The function returns @Nothing@ for non-@newtypes@, --- or unsaturated applications --- --- This function does *not* look through type families, because it has no access to --- the type family environment. If you do have that at hand, consider to use --- topNormaliseType_maybe, which should be a drop-in replacement for --- topNormaliseNewType_maybe --- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' -topNormaliseNewType_maybe ty - = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty - -{- -%************************************************************************ -%* * - Comparison of coercions -%* * -%************************************************************************ --} - --- | Syntactic equality of coercions -eqCoercion :: Coercion -> Coercion -> Bool -eqCoercion = eqType `on` coercionType - --- | Compare two 'Coercion's, with respect to an RnEnv2 -eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool -eqCoercionX env = eqTypeX env `on` coercionType - -{- -%************************************************************************ -%* * - "Lifting" substitution - [(TyCoVar,Coercion)] -> Type -> Coercion -%* * -%************************************************************************ - -Note [Lifting coercions over types: liftCoSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The KPUSH rule deals with this situation - data T a = K (a -> Maybe a) - g :: T t1 ~ T t2 - x :: t1 -> Maybe t1 - - case (K @t1 x) |> g of - K (y:t2 -> Maybe t2) -> rhs - -We want to push the coercion inside the constructor application. -So we do this - - g' :: t1~t2 = Nth 0 g - - case K @t2 (x |> g' -> Maybe g') of - K (y:t2 -> Maybe t2) -> rhs - -The crucial operation is that we - * take the type of K's argument: a -> Maybe a - * and substitute g' for a -thus giving *coercion*. This is what liftCoSubst does. - -In the presence of kind coercions, this is a bit -of a hairy operation. So, we refer you to the paper introducing kind coercions, -available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf - -Note [extendLiftingContextEx] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we have datatype - K :: \/k. \/a::k. P -> T k -- P be some type - g :: T k1 ~ T k2 - - case (K @k1 @t1 x) |> g of - K y -> rhs - -We want to push the coercion inside the constructor application. -We first get the coercion mapped by the universal type variable k: - lc = k |-> Nth 0 g :: k1~k2 - -Here, the important point is that the kind of a is coerced, and P might be -dependent on the existential type variable a. -Thus we first get the coercion of a's kind - g2 = liftCoSubst lc k :: k1 ~ k2 - -Then we store a new mapping into the lifting context - lc2 = a |-> (t1 ~ t1 |> g2), lc - -So later when we can correctly deal with the argument type P - liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] - -This is exactly what extendLiftingContextEx does. -* For each (tyvar:k, ty) pair, we product the mapping - tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) -* For each (covar:s1~s2, ty) pair, we produce the mapping - covar |-> (co ~ co') - co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' - -This follows the lifting context extension definition in the -"FC with Explicit Kind Equality" paper. --} - --- ---------------------------------------------------- --- See Note [Lifting coercions over types: liftCoSubst] --- ---------------------------------------------------- - -data LiftingContext = LC TCvSubst LiftCoEnv - -- in optCoercion, we need to lift when optimizing InstCo. - -- See Note [Optimising InstCo] in OptCoercion - -- We thus propagate the substitution from OptCoercion here. - -instance Outputable LiftingContext where - ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) - -type LiftCoEnv = VarEnv Coercion - -- Maps *type variables* to *coercions*. - -- That's the whole point of this function! - -- Also maps coercion variables to ProofIrrelCos. - --- like liftCoSubstWith, but allows for existentially-bound types as well -liftCoSubstWithEx :: Role -- desired role for output coercion - -> [TyVar] -- universally quantified tyvars - -> [Coercion] -- coercions to substitute for those - -> [TyCoVar] -- existentially quantified tycovars - -> [Type] -- types and coercions to be bound to ex vars - -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) -liftCoSubstWithEx role univs omegas exs rhos - = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) - psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) - in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) - -liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion -liftCoSubstWith r tvs cos ty - = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty - --- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) --- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where --- @lc_left@ is a substitution mapping type variables to the left-hand --- types of the mapped coercions in @lc@, and similar for @lc_right@. -liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion -liftCoSubst r lc@(LC subst env) ty - | isEmptyVarEnv env = mkReflCo r (substTy subst ty) - | otherwise = ty_co_subst lc r ty - -emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv - -mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext -mkLiftingContext pairs - = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) - (mkVarEnv pairs) - -mkSubstLiftingContext :: TCvSubst -> LiftingContext -mkSubstLiftingContext subst = LC subst emptyVarEnv - --- | Extend a lifting context with a new mapping. -extendLiftingContext :: LiftingContext -- ^ original LC - -> TyCoVar -- ^ new variable to map... - -> Coercion -- ^ ...to this lifted version - -> LiftingContext - -- mappings to reflexive coercions are just substitutions -extendLiftingContext (LC subst env) tv arg - | Just (ty, _) <- isReflCo_maybe arg - = LC (extendTCvSubst subst tv ty) env - | otherwise - = LC subst (extendVarEnv env tv arg) - --- | Extend a lifting context with a new mapping, and extend the in-scope set -extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC - -> TyCoVar -- ^ new variable to map... - -> Coercion -- ^ to this coercion - -> LiftingContext -extendLiftingContextAndInScope (LC subst env) tv co - = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co - --- | Extend a lifting context with existential-variable bindings. --- See Note [extendLiftingContextEx] -extendLiftingContextEx :: LiftingContext -- ^ original lifting context - -> [(TyCoVar,Type)] -- ^ ex. var / value pairs - -> LiftingContext --- Note that this is more involved than extendLiftingContext. That function --- takes a coercion to extend with, so it's assumed that the caller has taken --- into account any of the kind-changing stuff worried about here. -extendLiftingContextEx lc [] = lc -extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) --- This function adds bindings for *Nominal* coercions. Why? Because it --- works with existentially bound variables, which are considered to have --- nominal roles. - | isTyVar v - = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) - (extendVarEnv env v $ - mkGReflRightCo Nominal - ty - (ty_co_subst lc Nominal (tyVarKind v))) - in extendLiftingContextEx lc' rest - | CoercionTy co <- ty - = -- co :: s1 ~r s2 - -- lift_s1 :: s1 ~r s1' - -- lift_s2 :: s2 ~r s2' - -- kco :: (s1 ~r s2) ~N (s1' ~r s2') - ASSERT( isCoVar v ) - let (_, _, s1, s2, r) = coVarKindsTypesRole v - lift_s1 = ty_co_subst lc r s1 - lift_s2 = ty_co_subst lc r s2 - kco = mkTyConAppCo Nominal (equalityTyCon r) - [ mkKindCo lift_s1, mkKindCo lift_s2 - , lift_s1 , lift_s2 ] - lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) - (extendVarEnv env v - (mkProofIrrelCo Nominal kco co $ - (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) - in extendLiftingContextEx lc' rest - | otherwise - = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) - - --- | Erase the environments in a lifting context -zapLiftingContext :: LiftingContext -> LiftingContext -zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv - --- | Like 'substForAllCoBndr', but works on a lifting context -substForAllCoBndrUsingLC :: Bool - -> (Coercion -> Coercion) - -> LiftingContext -> TyCoVar -> Coercion - -> (LiftingContext, TyCoVar, Coercion) -substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co - = (LC subst' lc_env, tv', co') - where - (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co - --- | The \"lifting\" operation which substitutes coercions for type --- variables in a type to produce a coercion. --- --- For the inverse operation, see 'liftCoMatch' -ty_co_subst :: LiftingContext -> Role -> Type -> Coercion -ty_co_subst lc role ty - = go role ty - where - go :: Role -> Type -> Coercion - go r ty | Just ty' <- coreView ty - = go r ty' - go Phantom ty = lift_phantom ty - go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ - liftCoSubstTyVar lc r tv - go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) - go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) - go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) - go r t@(ForAllTy (Bndr v _) ty) - = let (lc', v', h) = liftCoSubstVarBndr lc v - body_co = ty_co_subst lc' r ty in - if isTyVar v' || almostDevoidCoVarOfCo v' body_co - -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo - -- imposes an extra restriction on where a covar can appear. See last - -- wrinkle in Note [Unused coercion variable in ForAllCo]. - -- We specifically check for this and panic because we know that - -- there's a hole in the type system here, and we'd rather panic than - -- fall into it. - then mkForAllCo v' h body_co - else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) - go r ty@(LitTy {}) = ASSERT( r == Nominal ) - mkNomReflCo ty - go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co) - (substRightCo lc co) - go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) - (substRightCo lc co) - where kco = go Nominal (coercionType co) - - lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) - (substTy (lcSubstLeft lc) ty) - (substTy (lcSubstRight lc) ty) - -{- -Note [liftCoSubstTyVar] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This function can fail if a coercion in the environment is of too low a role. - -liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and -also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting -lemma guarantees that the roles work out. If we fail in this -case, we really should panic -- something is deeply wrong. But, in matchAxiom, -failing is fine. matchAxiom is trying to find a set of coercions -that match, but it may fail, and this is healthy behavior. --} - --- See Note [liftCoSubstTyVar] -liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LC subst env) r v - | Just co_arg <- lookupVarEnv env v - = downgradeRole_maybe r (coercionRole co_arg) co_arg - - | otherwise - = Just $ mkReflCo r (substTyVar subst v) - -{- Note [liftCoSubstVarBndr] - -callback: - We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in - FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type - in snd. - However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and - ignore the fourth component of the return value. - -liftCoSubstTyVarBndrUsing: - Given - forall tv:k. t - We want to get - forall (tv:k1) (kind_co :: k1 ~ k2) body_co - - We lift the kind k to get the kind_co - kind_co = ty_co_subst k :: k1 ~ k2 - - Now in the LiftingContext, we add the new mapping - tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) - -liftCoSubstCoVarBndrUsing: - Given - forall cv:(s1 ~ s2). t - We want to get - forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co - - We lift s1 and s2 respectively to get - eta1 :: s1' ~ t1 - eta2 :: s2' ~ t2 - And - kind_co = TyConAppCo Nominal (~#) eta1 eta2 - - Now in the liftingContext, we add the new mapping - cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) --} - --- See Note [liftCoSubstVarBndr] -liftCoSubstVarBndr :: LiftingContext -> TyCoVar - -> (LiftingContext, TyCoVar, Coercion) -liftCoSubstVarBndr lc tv - = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in - (lc', tv', h) - where - callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) - --- the callback must produce a nominal coercion -liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) - -> LiftingContext -> TyCoVar - -> (LiftingContext, TyCoVar, CoercionN, a) -liftCoSubstVarBndrUsing fun lc old_var - | isTyVar old_var - = liftCoSubstTyVarBndrUsing fun lc old_var - | otherwise - = liftCoSubstCoVarBndrUsing fun lc old_var - --- Works for tyvar binder -liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) - -> LiftingContext -> TyVar - -> (LiftingContext, TyVar, CoercionN, a) -liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var - = ASSERT( isTyVar old_var ) - ( LC (subst `extendTCvInScope` new_var) new_cenv - , new_var, eta, stuff ) - where - old_kind = tyVarKind old_var - (eta, stuff) = fun lc old_kind - k1 = coercionLKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - - lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta - -- :: new_var ~ new_var |> eta - new_cenv = extendVarEnv cenv old_var lifted - --- Works for covar binder -liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) - -> LiftingContext -> CoVar - -> (LiftingContext, CoVar, CoercionN, a) -liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var - = ASSERT( isCoVar old_var ) - ( LC (subst `extendTCvInScope` new_var) new_cenv - , new_var, kind_co, stuff ) - where - old_kind = coVarKind old_var - (eta, stuff) = fun lc old_kind - k1 = coercionLKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - - -- old_var :: s1 ~r s2 - -- eta :: (s1' ~r s2') ~N (t1 ~r t2) - -- eta1 :: s1' ~r t1 - -- eta2 :: s2' ~r t2 - -- co1 :: s1' ~r s2' - -- co2 :: t1 ~r t2 - -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) - -- lifted :: co1 ~N co2 - - role = coVarRole old_var - eta' = downgradeRole role Nominal eta - eta1 = mkNthCo role 2 eta' - eta2 = mkNthCo role 3 eta' - - co1 = mkCoVarCo new_var - co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 - kind_co = mkTyConAppCo Nominal (equalityTyCon role) - [ mkKindCo co1, mkKindCo co2 - , co1 , co2 ] - lifted = mkProofIrrelCo Nominal kind_co co1 co2 - - new_cenv = extendVarEnv cenv old_var lifted - --- | Is a var in the domain of a lifting context? -isMappedByLC :: TyCoVar -> LiftingContext -> Bool -isMappedByLC tv (LC _ env) = tv `elemVarEnv` env - --- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 --- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 -substLeftCo :: LiftingContext -> Coercion -> Coercion -substLeftCo lc co - = substCo (lcSubstLeft lc) co - --- Ditto, but for t2 and g2 -substRightCo :: LiftingContext -> Coercion -> Coercion -substRightCo lc co - = substCo (lcSubstRight lc) co - --- | Apply "sym" to all coercions in a 'LiftCoEnv' -swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv -swapLiftCoEnv = mapVarEnv mkSymCo - -lcSubstLeft :: LiftingContext -> TCvSubst -lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env - -lcSubstRight :: LiftingContext -> TCvSubst -lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env - -liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubstLeft = liftEnvSubst pFst - -liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubstRight = liftEnvSubst pSnd - -liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubst selector subst lc_env - = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst - where - pairs = nonDetUFMToList lc_env - -- It's OK to use nonDetUFMToList here because we - -- immediately forget the ordering by creating - -- a VarEnv - (tpairs, cpairs) = partitionWith ty_or_co pairs - tenv = mkVarEnv_Directly tpairs - cenv = mkVarEnv_Directly cpairs - - ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) - ty_or_co (u, co) - | Just equality_co <- isCoercionTy_maybe equality_ty - = Right (u, equality_co) - | otherwise - = Left (u, equality_ty) - where - equality_ty = selector (coercionKind co) - --- | Extract the underlying substitution from the LiftingContext -lcTCvSubst :: LiftingContext -> TCvSubst -lcTCvSubst (LC subst _) = subst - --- | Get the 'InScopeSet' from a 'LiftingContext' -lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getTCvInScope subst - -{- -%************************************************************************ -%* * - Sequencing on coercions -%* * -%************************************************************************ --} - -seqMCo :: MCoercion -> () -seqMCo MRefl = () -seqMCo (MCo co) = seqCo co - -seqCo :: Coercion -> () -seqCo (Refl ty) = seqType ty -seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco -seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos -seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k - `seq` seqCo co -seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 -seqCo (CoVarCo cv) = cv `seq` () -seqCo (HoleCo h) = coHoleCoVar h `seq` () -seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo p r t1 t2) - = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 -seqCo (SymCo co) = seqCo co -seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (NthCo r n co) = r `seq` n `seq` seqCo co -seqCo (LRCo lr co) = lr `seq` seqCo co -seqCo (InstCo co arg) = seqCo co `seq` seqCo arg -seqCo (KindCo co) = seqCo co -seqCo (SubCo co) = seqCo co -seqCo (AxiomRuleCo _ cs) = seqCos cs - -seqProv :: UnivCoProvenance -> () -seqProv (PhantomProv co) = seqCo co -seqProv (ProofIrrelProv co) = seqCo co -seqProv (PluginProv _) = () - -seqCos :: [Coercion] -> () -seqCos [] = () -seqCos (co:cos) = seqCo co `seq` seqCos cos - -{- -%************************************************************************ -%* * - The kind of a type, and of a coercion -%* * -%************************************************************************ --} - --- | Apply 'coercionKind' to multiple 'Coercion's -coercionKinds :: [Coercion] -> Pair [Type] -coercionKinds tys = sequenceA $ map coercionKind tys - --- | Get a coercion's kind and role. -coercionKindRole :: Coercion -> (Pair Type, Role) -coercionKindRole co = (coercionKind co, coercionRole co) - -coercionType :: Coercion -> Type -coercionType co = case coercionKindRole co of - (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 - ------------------- --- | If it is the case that --- --- > c :: (t1 ~ t2) --- --- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. - -coercionKind :: Coercion -> Pair Type -coercionKind co = Pair (coercionLKind co) (coercionRKind co) - -coercionLKind :: Coercion -> Type -coercionLKind co - = go co - where - go (Refl ty) = ty - go (GRefl _ ty _) = ty - go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) - go (AppCo co1 co2) = mkAppTy (go co1) (go co2) - go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) - go (FunCo _ co1 co2) = mkVisFunTy (go co1) (go co2) - go (CoVarCo cv) = coVarLType cv - go (HoleCo h) = coVarLType (coHoleCoVar h) - go (UnivCo _ _ ty1 _) = ty1 - go (SymCo co) = coercionRKind co - go (TransCo co1 _) = go co1 - go (LRCo lr co) = pickLR lr (splitAppTy (go co)) - go (InstCo aco arg) = go_app aco [go arg] - go (KindCo co) = typeKind (go co) - go (SubCo co) = go co - go (NthCo _ d co) = go_nth d (go co) - go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) - go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ - coaxrProves ax $ map coercionKind cos - - go_ax_inst ax ind tys - | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs } <- coAxiomNthBranch ax ind - , let (tys1, cotys1) = splitAtList tvs tys - cos1 = map stripCoercionTy cotys1 - = ASSERT( tys `equalLength` (tvs ++ cvs) ) - -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - substTyWith tvs tys1 $ - substTyWithCoVars cvs cos1 $ - mkTyConApp (coAxiomTyCon ax) lhs - - go_app :: Coercion -> [Type] -> Type - -- Collect up all the arguments and apply all at once - -- See Note [Nested InstCos] - go_app (InstCo co arg) args = go_app co (go arg:args) - go_app co args = piResultTys (go co) args - -go_nth :: Int -> Type -> Type -go_nth d ty - | Just args <- tyConAppArgs_maybe ty - = ASSERT( args `lengthExceeds` d ) - args `getNth` d - - | d == 0 - , Just (tv,_) <- splitForAllTy_maybe ty - = tyVarKind tv - - | otherwise - = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty) - -coercionRKind :: Coercion -> Type -coercionRKind co - = go co - where - go (Refl ty) = ty - go (GRefl _ ty MRefl) = ty - go (GRefl _ ty (MCo co1)) = mkCastTy ty co1 - go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) - go (AppCo co1 co2) = mkAppTy (go co1) (go co2) - go (CoVarCo cv) = coVarRType cv - go (HoleCo h) = coVarRType (coHoleCoVar h) - go (FunCo _ co1 co2) = mkVisFunTy (go co1) (go co2) - go (UnivCo _ _ _ ty2) = ty2 - go (SymCo co) = coercionLKind co - go (TransCo _ co2) = go co2 - go (LRCo lr co) = pickLR lr (splitAppTy (go co)) - go (InstCo aco arg) = go_app aco [go arg] - go (KindCo co) = typeKind (go co) - go (SubCo co) = go co - go (NthCo _ d co) = go_nth d (go co) - go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) - go (AxiomRuleCo ax cos) = pSnd $ expectJust "coercionKind" $ - coaxrProves ax $ map coercionKind cos - - go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar - | isGReflCo k_co = mkTyCoInvForAllTy tv1 (go co1) - -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = go_forall empty_subst co - where - empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) - - go_ax_inst ax ind tys - | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind - , let (tys2, cotys2) = splitAtList tvs tys - cos2 = map stripCoercionTy cotys2 - = ASSERT( tys `equalLength` (tvs ++ cvs) ) - -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - substTyWith tvs tys2 $ - substTyWithCoVars cvs cos2 rhs - - go_app :: Coercion -> [Type] -> Type - -- Collect up all the arguments and apply all at once - -- See Note [Nested InstCos] - go_app (InstCo co arg) args = go_app co (go arg:args) - go_app co args = piResultTys (go co) args - - go_forall subst (ForAllCo tv1 k_co co) - -- See Note [Nested ForAllCos] - | isTyVar tv1 - = mkInvForAllTy tv2 (go_forall subst' co) - where - k2 = coercionRKind k_co - tv2 = setTyVarKind tv1 (substTy subst k2) - subst' | isGReflCo k_co = extendTCvInScope subst tv1 - -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ - TyVarTy tv2 `mkCastTy` mkSymCo k_co - - go_forall subst (ForAllCo cv1 k_co co) - | isCoVar cv1 - = mkTyCoInvForAllTy cv2 (go_forall subst' co) - where - k2 = coercionRKind k_co - r = coVarRole cv1 - eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) - eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) - - -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) - -- k1 = t1 ~r t2 - -- k2 = s1 ~r s2 - -- cv1 :: t1 ~r t2 - -- cv2 :: s1 ~r s2 - -- eta1 :: t1 ~r s1 - -- eta2 :: t2 ~r s2 - -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 - - cv2 = setVarType cv1 (substTy subst k2) - n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) - subst' | isReflCo k_co = extendTCvInScope subst cv1 - | otherwise = extendCvSubst (extendTCvInScope subst cv2) - cv1 n_subst - - go_forall subst other_co - -- when other_co is not a ForAllCo - = substTy subst (go other_co) - -{- - -Note [Nested ForAllCos] -~~~~~~~~~~~~~~~~~~~~~~~ - -Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an -co)...) )`. We do not want to perform `n` single-type-variable -substitutions over the kind of `co`; rather we want to do one substitution -which substitutes for all of `a1`, `a2` ... simultaneously. If we do one -at a time we get the performance hole reported in #11735. - -Solution: gather up the type variables for nested `ForAllCos`, and -substitute for them all at once. Remarkably, for #11735 this single -change reduces /total/ compile time by a factor of more than ten. - --} - --- | Retrieve the role from a coercion. -coercionRole :: Coercion -> Role -coercionRole = go - where - go (Refl _) = Nominal - go (GRefl r _ _) = r - go (TyConAppCo r _ _) = r - go (AppCo co1 _) = go co1 - go (ForAllCo _ _ co) = go co - go (FunCo r _ _) = r - go (CoVarCo cv) = coVarRole cv - go (HoleCo h) = coVarRole (coHoleCoVar h) - go (AxiomInstCo ax _ _) = coAxiomRole ax - go (UnivCo _ r _ _) = r - go (SymCo co) = go co - go (TransCo co1 _co2) = go co1 - go (NthCo r _d _co) = r - go (LRCo {}) = Nominal - go (InstCo co _) = go co - go (KindCo {}) = Nominal - go (SubCo _) = Representational - go (AxiomRuleCo ax _) = coaxrRole ax - -{- -Note [Nested InstCos] -~~~~~~~~~~~~~~~~~~~~~ -In #5631 we found that 70% of the entire compilation time was -being spent in coercionKind! The reason was that we had - (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos -where - g :: forall a1 a2 .. a100. phi -If we deal with the InstCos one at a time, we'll do this: - 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' - 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst -But this is a *quadratic* algorithm, and the blew up #5631. -So it's very important to do the substitution simultaneously; -cf Type.piResultTys (which in fact we call here). - --} - --- | Makes a coercion type from two types: the types whose equality --- is proven by the relevant 'Coercion' -mkCoercionType :: Role -> Type -> Type -> Type -mkCoercionType Nominal = mkPrimEqPred -mkCoercionType Representational = mkReprPrimEqPred -mkCoercionType Phantom = \ty1 ty2 -> - let ki1 = typeKind ty1 - ki2 = typeKind ty2 - in - TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] - -mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type -mkHeteroCoercionType Nominal = mkHeteroPrimEqPred -mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred -mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" - --- | Creates a primitive type equality predicate. --- Invariant: the types are not Coercions -mkPrimEqPred :: Type -> Type -> Type -mkPrimEqPred ty1 ty2 - = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Makes a lifted equality predicate at the given role -mkPrimEqPredRole :: Role -> Type -> Type -> PredType -mkPrimEqPredRole Nominal = mkPrimEqPred -mkPrimEqPredRole Representational = mkReprPrimEqPred -mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" - --- | Creates a primite type equality predicate with explicit kinds -mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] - --- | Creates a primitive representational type equality predicate --- with explicit kinds -mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroReprPrimEqPred k1 k2 ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - -mkReprPrimEqPred :: Type -> Type -> Type -mkReprPrimEqPred ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Assuming that two types are the same, ignoring coercions, find --- a nominal coercion between the types. This is useful when optimizing --- transitivity over coercion applications, where splitting two --- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion. -buildCoercion :: Type -> Type -> CoercionN -buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 - | Just ty2' <- coreView ty2 = go ty1 ty2' - - go (CastTy ty1 co) ty2 - = let co' = go ty1 ty2 - r = coercionRole co' - in mkCoherenceLeftCo r ty1 co co' - - go ty1 (CastTy ty2 co) - = let co' = go ty1 ty2 - r = coercionRole co' - in mkCoherenceRightCo r ty2 co co' - - go ty1@(TyVarTy tv1) _tyvarty - = ASSERT( case _tyvarty of - { TyVarTy tv2 -> tv1 == tv2 - ; _ -> False } ) - mkNomReflCo ty1 - - go (FunTy { ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_arg = arg2, ft_res = res2 }) - = mkFunCo Nominal (go arg1 arg2) (go res1 res2) - - go (TyConApp tc1 args1) (TyConApp tc2 args2) - = ASSERT( tc1 == tc2 ) - mkTyConAppCo Nominal tc1 (zipWith go args1 args2) - - go (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 - = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - - go ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - - go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) - | isTyVar tv1 - = ASSERT( isTyVar tv2 ) - mkForAllCo tv1 kind_co (go ty1 ty2') - where kind_co = go (tyVarKind tv1) (tyVarKind tv2) - in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co - ty2' = substTyWithInScope in_scope [tv2] - [mkTyVarTy tv1 `mkCastTy` kind_co] - ty2 - - go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) - = ASSERT( isCoVar cv1 && isCoVar cv2 ) - mkForAllCo cv1 kind_co (go ty1 ty2') - where s1 = varType cv1 - s2 = varType cv2 - kind_co = go s1 s2 - - -- s1 = t1 ~r t2 - -- s2 = t3 ~r t4 - -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) - -- eta1 :: t1 ~r t3 - -- eta2 :: t2 ~r t4 - - r = coVarRole cv1 - kind_co' = downgradeRole r Nominal kind_co - eta1 = mkNthCo r 2 kind_co' - eta2 = mkNthCo r 3 kind_co' - - subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co - ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` - mkCoVarCo cv1 `mkTransCo` - eta2) - ty2 - - go ty1@(LitTy lit1) _lit2 - = ASSERT( case _lit2 of - { LitTy lit2 -> lit1 == lit2 - ; _ -> False } ) - mkNomReflCo ty1 - - go (CoercionTy co1) (CoercionTy co2) - = mkProofIrrelCo Nominal kind_co co1 co2 - where - kind_co = go (coercionType co1) (coercionType co2) - - go ty1 ty2 - = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 - , ppr ty1, ppr ty2 ]) - -{- -%************************************************************************ -%* * - Simplifying types -%* * -%************************************************************************ - -The function below morally belongs in TcFlatten, but it is used also in -FamInstEnv, and so lives here. - -Note [simplifyArgsWorker] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariant (F2) of Note [Flattening] says that flattening is homogeneous. -This causes some trouble when flattening a function applied to a telescope -of arguments, perhaps with dependency. For example, suppose - - type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] - -and we wish to flatten the args of (with kind applications explicit) - - F a b (Just a c) (Right a b d) False - -where all variables are skolems and - - a :: Type - b :: Type - c :: a - d :: k - - [G] aco :: a ~ fa - [G] bco :: b ~ fb - [G] cco :: c ~ fc - [G] dco :: d ~ fd - -The first step is to flatten all the arguments. This is done before calling -simplifyArgsWorker. We start from - - a - b - Just a c - Right a b d - False - -and get - - (fa, co1 :: fa ~ a) - (fb, co2 :: fb ~ b) - (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) - (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) - (False, co5 :: False ~ False) - -where - co6 :: Maybe fa ~ Maybe a - co7 :: Either fa fb ~ Either a b - -We now process the flattened args in left-to-right order. The first two args -need no further processing. But now consider the third argument. Let f3 = the flattened -result, Just fa (fc |> aco) |> co6. -This f3 flattened argument has kind (Maybe a), due to -(F2). And yet, when we build the application (F fa fb ...), we need this -argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. -The coercion to use is -determined by the kind of F: we see in F's kind that the third argument has -kind Maybe j. Critically, we also know that the argument corresponding to j -(in our example, a) flattened with a coercion co1. We can thus know the -coercion needed for the 3rd argument is (Maybe (sym co1)), thus building -(f3 |> Maybe (sym co1)) - -More generally, we must use the Lifting Lemma, as implemented in -Coercion.liftCoSubst. As we work left-to-right, any variable that is a -dependent parameter (j and k, in our example) gets mapped in a lifting context -to the coercion that is output from flattening the corresponding argument (co1 -and co2, in our example). Then, after flattening later arguments, we lift the -kind of these arguments in the lifting context that we've be building up. -This coercion is then used to keep the result of flattening well-kinded. - -Working through our example, this is what happens: - - 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, - because the binder associated with the first argument has a closed type (no - variables). - - 2. Extend the LC with [k |-> co2]. No casting to do. - - 3. Lifting the kind (Maybe j) with our LC - yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to - F. - - 4. Lifting the kind (Either j k) with our LC - yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th - argument to F, where f4 is the flattened form of argument 4, written above. - - 5. We lift Bool with our LC, getting ; - casting has no effect. - -We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) -has the wrong kind. Its kind is [fb], instead of the original [b]. -So we must use our LC one last time to lift the result kind [k], -getting res_co :: [fb] ~ [b], and we cast our result. - -Accordingly, the final result is - - F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) - (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) - False - |> [sym bco] - -The res_co (in this case, [sym bco]) -is returned as the third return value from simplifyArgsWorker. - -Note [Last case in simplifyArgsWorker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, -because that case is first. We've run out of -binders. But perhaps inner_ki is a tyvar that has been instantiated with a -Π-type. - -Here is an example. - - a :: forall (k :: Type). k -> k - type family Star - Proxy :: forall j. j -> Type - axStar :: Star ~ Type - type family NoWay :: Bool - axNoWay :: NoWay ~ False - bo :: Type - [G] bc :: bo ~ Bool (in inert set) - - co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) - co = forall (j :: sym axStar). ( -> sym axStar) - - We are flattening: - a (forall (j :: Star). (j |> axStar) -> Star) -- 1 - (Proxy |> co) -- 2 - (bo |> sym axStar) -- 3 - (NoWay |> sym bc) -- 4 - :: Star - -First, we flatten all the arguments (before simplifyArgsWorker), like so: - - (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ - (forall (j :: Star). (j |> axStar) -> Star)) -- 1 - (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 - (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 - (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 - -Then we do the process described in Note [simplifyArgsWorker]. - -1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we - don't use it. But we do build a lifting context [k -> co1] (where co1 is a - result of flattening an argument, written above). - -2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). - This is not a dependent argument, so we don't extend the lifting context. - -Now we need to deal with argument (3). -The way we normally proceed is to lift the kind of the binder, to see whether -it's dependent. -But here, the remainder of the kind of `a` that we're left with -after processing two arguments is just `k`. - -The way forward is look up k in the lifting context, getting co1. If we're at -all well-typed, co1 will be a coercion between Π-types, with at least one binder. -So, let's -decompose co1 with decomposePiCos. This decomposition needs arguments to use -to instantiate any kind parameters. Look at the type of co1. If we just -decomposed it, we would end up with coercions whose types include j, which is -out of scope here. Accordingly, decomposePiCos takes a list of types whose -kinds are the *right-hand* types in the decomposed coercion. (See comments on -decomposePiCos.) Because the flattened types have unflattened kinds (because -flattening is homogeneous), passing the list of flattened types to decomposePiCos -just won't do: later arguments' kinds won't be as expected. So we need to get -the *unflattened* types to pass to decomposePiCos. We can do this easily enough -by taking the kind of the argument coercions, passed in originally. - -(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. -But that function is already gnarly, and taking the right-hand types is correct -at its other call sites, which are much more common than this one.) - -(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its -behavior into simplifyArgsWorker. This would work, I think, but then all of the -complication of decomposePiCos would end up layered on top of all the complication -here. Please, no.) - -(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker -so that we don't have to recreate them. But that would complicate the interface -of this function to handle a very dark, dark corner case. Better to keep our -demons to ourselves here instead of exposing them to callers. This decision is -easily reversed if there is ever any performance trouble due to the call of -coercionKind.) - -So we now call - - decomposePiCos co1 - (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) - [bo |> sym axStar, NoWay |> sym bc] - -to get - - co5 :: Star ~ Type - co6 :: (j |> axStar) ~ (j |> co5), substituted to - (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) - == bo ~ bo - res_co :: Type ~ Star - -We then use these casts on (the flattened) (3) and (4) to get - - (Bool |> sym axStar |> co5 :: Type) -- (C3) - (False |> sym bc |> co6 :: bo) -- (C4) - -We can simplify to - - Bool -- (C3) - (False |> sym bc :: bo) -- (C4) - -Of course, we still must do the processing in Note [simplifyArgsWorker] to finish -the job. We thus want to recur. Our new function kind is the left-hand type of -co1 (gotten, recall, by lifting the variable k that was the return kind of the -original function). Why the left-hand type (as opposed to the right-hand type)? -Because we have casted all the arguments according to decomposePiCos, which gets -us from the right-hand type to the left-hand one. We thus recur with that new -function kind, zapping our lifting context, because we have essentially applied -it. - -This recursive call returns ([Bool, False], [...], Refl). The Bool and False -are the correct arguments we wish to return. But we must be careful about the -result coercion: our new, flattened application will have kind Type, but we -want to make sure that the result coercion casts this back to Star. (Why? -Because we started with an application of kind Star, and flattening is homogeneous.) - -So, we have to twiddle the result coercion appropriately. - -Let's check whether this is well-typed. We know - - a :: forall (k :: Type). k -> k - - a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type - - a (forall j. j -> Type) - Proxy - :: forall j. j -> Type - - a (forall j. j -> Type) - Proxy - Bool - :: Bool -> Type - - a (forall j. j -> Type) - Proxy - Bool - False - :: Type - - a (forall j. j -> Type) - Proxy - Bool - False - |> res_co - :: Star - -as desired. - -Whew. - -Historical note: I (Richard E) once thought that the final part of the kind -had to be a variable k (as in the example above). But it might not be: it could -be an application of a variable. Here is the example: - - let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) - k :: Type - x :: k - - flatten (f @Type @((->) k) x) - -After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` -is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. - --} - - --- This is shared between the flattener and the normaliser in FamInstEnv. --- See Note [simplifyArgsWorker] -{-# INLINE simplifyArgsWorker #-} -simplifyArgsWorker :: [TyCoBinder] -> Kind - -- the binders & result kind (not a Π-type) of the function applied to the args - -- list of binders can be shorter or longer than the list of args - -> TyCoVarSet -- free vars of the args - -> [Role] -- list of roles, r - -> [(Type, Coercion)] -- flattened type arguments, arg - -- each comes with the coercion used to flatten it, - -- with co :: flattened_type ~ original_type - -> ([Type], [Coercion], CoercionN) --- Returns (xis, cos, res_co), where each co :: xi ~ arg, --- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args --- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), --- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. --- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this --- function is all about. That is, (f xis), where xis are the returned arguments, *is* --- well kinded. -simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs - orig_roles orig_simplified_args - = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args - where - orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs - - go :: [Type] -- Xis accumulator, in reverse order - -> [Coercion] -- Coercions accumulator, in reverse order - -- These are in 1-to-1 correspondence - -> LiftingContext -- mapping from tyvars to flattening coercions - -> [TyCoBinder] -- Unsubsted binders of function's kind - -> Kind -- Unsubsted result kind of function (not a Pi-type) - -> [Role] -- Roles at which to flatten these ... - -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions - -> ([Type], [Coercion], CoercionN) - go acc_xis acc_cos lc binders inner_ki _ [] - = (reverse acc_xis, reverse acc_cos, kind_co) - where - final_kind = mkPiTys binders inner_ki - kind_co = liftCoSubst Nominal lc final_kind - - go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) - = -- By Note [Flattening] in TcFlatten invariant (F2), - -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be - -- used as an argument to a function whose kind is different, if - -- earlier arguments have been flattened to new types. We thus - -- need a coercion (kind_co :: old_kind ~ new_kind). - -- - -- The bangs here have been observed to improve performance - -- significantly in optimized builds. - let kind_co = mkSymCo $ - liftCoSubst Nominal lc (tyCoBinderType binder) - !casted_xi = xi `mkCastTy` kind_co - casted_co = mkCoherenceLeftCo role xi kind_co co - - -- now, extend the lifting context with the new binding - !new_lc | Just tv <- tyCoBinderVar_maybe binder - = extendLiftingContextAndInScope lc tv casted_co - | otherwise - = lc - in - go (casted_xi : acc_xis) - (casted_co : acc_cos) - new_lc - binders - inner_ki - roles - args - - - -- See Note [Last case in simplifyArgsWorker] - go acc_xis acc_cos lc [] inner_ki roles args - = let co1 = liftCoSubst Nominal lc inner_ki - co1_kind = coercionKind co1 - unflattened_tys = map (coercionRKind . snd) args - (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys - casted_args = ASSERT2( equalLength args arg_cos - , ppr args $$ ppr arg_cos ) - [ (casted_xi, casted_co) - | ((xi, co), arg_co, role) <- zip3 args arg_cos roles - , let casted_xi = xi `mkCastTy` arg_co - casted_co = mkCoherenceLeftCo role xi arg_co co ] - -- In general decomposePiCos can return fewer cos than tys, - -- but not here; because we're well typed, there will be enough - -- binders. Note that decomposePiCos does substitutions, so even - -- if the original substitution results in something ending with - -- ... -> k, that k will be substituted to perhaps reveal more - -- binders. - zapped_lc = zapLiftingContext lc - Pair flattened_kind _ = co1_kind - (bndrs, new_inner) = splitPiTys flattened_kind - - (xis_out, cos_out, res_co_out) - = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args - in - (xis_out, cos_out, res_co_out `mkTransCo` res_co) - - go _ _ _ _ _ _ _ = panic - "simplifyArgsWorker wandered into deeper water than usual" - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872d. - -- That's independent of the analogous case in flatten_args_fast - -- in TcFlatten: - -- each of these causes a 2% increase on its own, so commenting them - -- both out gives a 4% decrease in T9872d. - {- - - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot deleted file mode 100644 --- a/compiler/types/Coercion.hs-boot +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Coercion where - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep -import {-# SOURCE #-} TyCon - -import BasicTypes ( LeftOrRight ) -import CoAxiom -import Var -import Pair -import Util - -mkReflCo :: Role -> Type -> Coercion -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkAppCo :: Coercion -> Coercion -> Coercion -mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkCoVarCo :: CoVar -> Coercion -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion -mkSymCo :: Coercion -> Coercion -mkTransCo :: Coercion -> Coercion -> Coercion -mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkInstCo :: Coercion -> Coercion -> Coercion -mkGReflCo :: Role -> Type -> MCoercionN -> Coercion -mkNomReflCo :: Type -> Coercion -mkKindCo :: Coercion -> Coercion -mkSubCo :: Coercion -> Coercion -mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion - -isGReflCo :: Coercion -> Bool -isReflCo :: Coercion -> Bool -isReflexiveCo :: Coercion -> Bool -decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) -coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) -coVarRole :: CoVar -> Role - -mkCoercionType :: Role -> Type -> Type -> Type - -data LiftingContext -liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion -seqCo :: Coercion -> () - -coercionKind :: Coercion -> Pair Type -coercionLKind :: Coercion -> Type -coercionRKind :: Coercion -> Type -coercionType :: Coercion -> Type diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs deleted file mode 100644 --- a/compiler/types/FamInstEnv.hs +++ /dev/null @@ -1,1833 +0,0 @@ --- (c) The University of Glasgow 2006 --- --- FamInstEnv: Type checked family instance declarations - -{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections, - DeriveFunctor #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, - famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInsts, - mkImportedFamInst, - - FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, extendFamInstEnvList, - famInstEnvElts, famInstEnvSize, familyInstances, - - -- * CoAxioms - mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, - mkNewTypeCoAxiom, - - FamInstMatch(..), - lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, - - isDominatedBy, apartnessCheck, - - -- Injectivity - InjectivityCheckResult(..), - lookupFamInstEnvInjectivityConflicts, injectiveBranches, - - -- Normalisation - topNormaliseType, topNormaliseType_maybe, - normaliseType, normaliseTcApp, normaliseTcArgs, - reduceTyFamApp_maybe, - - -- Flattening - flattenTys - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Unify -import Type -import TyCoRep -import TyCon -import Coercion -import CoAxiom -import VarSet -import VarEnv -import Name -import UniqDFM -import Outputable -import Maybes -import GHC.Core.Map -import Unique -import Util -import Var -import SrcLoc -import FastString -import Control.Monad -import Data.List( mapAccumL ) -import Data.Array( Array, assocs ) - -{- -************************************************************************ -* * - Type checked family instance heads -* * -************************************************************************ - -Note [FamInsts and CoAxioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* CoAxioms and FamInsts are just like - DFunIds and ClsInsts - -* A CoAxiom is a System-FC thing: it can relate any two types - -* A FamInst is a Haskell source-language thing, corresponding - to a type/data family instance declaration. - - The FamInst contains a CoAxiom, which is the evidence - for the instance - - - The LHS of the CoAxiom is always of form F ty1 .. tyn - where F is a type family --} - -data FamInst -- See Note [FamInsts and CoAxioms] - = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom - -- introduced by this family - -- instance - -- INVARIANT: apart from freshening (see below) - -- fi_tvs = cab_tvs of the (single) axiom branch - -- fi_cvs = cab_cvs ...ditto... - -- fi_tys = cab_lhs ...ditto... - -- fi_rhs = cab_rhs ...ditto... - - , fi_flavor :: FamFlavor - - -- Everything below here is a redundant, - -- cached version of the two things above - -- except that the TyVars are freshened - , fi_fam :: Name -- Family name - - -- Used for "rough matching"; same idea as for class instances - -- See Note [Rough-match field] in InstEnv - , fi_tcs :: [Maybe Name] -- Top of type args - -- INVARIANT: fi_tcs = roughMatchTcs fi_tys - - -- Used for "proper matching"; ditto - , fi_tvs :: [TyVar] -- Template tyvars for full match - , fi_cvs :: [CoVar] -- Template covars for full match - -- Like ClsInsts, these variables are always fresh - -- See Note [Template tyvars are fresh] in InstEnv - - , fi_tys :: [Type] -- The LHS type patterns - -- May be eta-reduced; see Note [Eta reduction for data families] - - , fi_rhs :: Type -- the RHS, with its freshened vars - } - -data FamFlavor - = SynFamilyInst -- A synonym family - | DataFamilyInst TyCon -- A data family, with its representation TyCon - -{- -Note [Arity of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Data family instances might legitimately be over- or under-saturated. - -Under-saturation has two potential causes: - U1) Eta reduction. See Note [Eta reduction for data families]. - U2) When the user has specified a return kind instead of written out patterns. - Example: - - data family Sing (a :: k) - data instance Sing :: Bool -> Type - - The data family tycon Sing has an arity of 2, the k and the a. But - the data instance has only one pattern, Bool (standing in for k). - This instance is equivalent to `data instance Sing (a :: Bool)`, but - without the last pattern, we have an under-saturated data family instance. - On its own, this example is not compelling enough to add support for - under-saturation, but U1 makes this feature more compelling. - -Over-saturation is also possible: - O1) If the data family's return kind is a type variable (see also #12369), - an instance might legitimately have more arguments than the family. - Example: - - data family Fix :: (Type -> k) -> k - data instance Fix f = MkFix1 (f (Fix f)) - data instance Fix f x = MkFix2 (f (Fix f x) x) - - In the first instance here, the k in the data family kind is chosen to - be Type. In the second, it's (Type -> Type). - - However, we require that any over-saturation is eta-reducible. That is, - we require that any extra patterns be bare unrepeated type variables; - see Note [Eta reduction for data families]. Accordingly, the FamInst - is never over-saturated. - -Why can we allow such flexibility for data families but not for type families? -Because data families can be decomposed -- that is, they are generative and -injective. A Type family is neither and so always must be applied to all its -arguments. --} - --- Obtain the axiom of a family instance -famInstAxiom :: FamInst -> CoAxiom Unbranched -famInstAxiom = fi_axiom - --- Split the left-hand side of the FamInst -famInstSplitLHS :: FamInst -> (TyCon, [Type]) -famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) - = (coAxiomTyCon axiom, lhs) - --- Get the RHS of the FamInst -famInstRHS :: FamInst -> Type -famInstRHS = fi_rhs - --- Get the family TyCon of the FamInst -famInstTyCon :: FamInst -> TyCon -famInstTyCon = coAxiomTyCon . famInstAxiom - --- Return the representation TyCons introduced by data family instances, if any -famInstsRepTyCons :: [FamInst] -> [TyCon] -famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] - --- Extracts the TyCon for this *data* (or newtype) instance -famInstRepTyCon_maybe :: FamInst -> Maybe TyCon -famInstRepTyCon_maybe fi - = case fi_flavor fi of - DataFamilyInst tycon -> Just tycon - SynFamilyInst -> Nothing - -dataFamInstRepTyCon :: FamInst -> TyCon -dataFamInstRepTyCon fi - = case fi_flavor fi of - DataFamilyInst tycon -> tycon - SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) - -{- -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -instance NamedThing FamInst where - getName = coAxiomName . fi_axiom - -instance Outputable FamInst where - ppr = pprFamInst - -pprFamInst :: FamInst -> SDoc --- Prints the FamInst as a family instance declaration --- NB: This function, FamInstEnv.pprFamInst, is used only for internal, --- debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user -pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax - , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) - = hang (ppr_tc_sort <+> text "instance" - <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) - 2 (whenPprDebug debug_stuff) - where - ppr_tc_sort = case flavor of - SynFamilyInst -> text "type" - DataFamilyInst tycon - | isDataTyCon tycon -> text "data" - | isNewTyCon tycon -> text "newtype" - | isAbstractTyCon tycon -> text "data" - | otherwise -> text "WEIRD" <+> ppr tycon - - debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax - , text "Tvs:" <+> ppr tvs - , text "LHS:" <+> ppr tys - , text "RHS:" <+> ppr rhs ] - -pprFamInsts :: [FamInst] -> SDoc -pprFamInsts finsts = vcat (map pprFamInst finsts) - -{- -Note [Lazy axiom match] -~~~~~~~~~~~~~~~~~~~~~~~ -It is Vitally Important that mkImportedFamInst is *lazy* in its axiom -parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime -later, mkImportedFamInst is called using that axiom. However, the axiom -may itself depend on entities which are not yet loaded as of the time -of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the -axiom, a dependency loop spontaneously appears and GHC hangs. The solution -is simply for mkImportedFamInst never, ever to look inside of the axiom -until everything else is good and ready to do so. We can assume that this -readiness has been achieved when some other code pulls on the axiom in the -FamInst. Thus, we pattern match on the axiom lazily (in the where clause, -not in the parameter list) and we assert the consistency of names there -also. --} - --- Make a family instance representation from the information found in an --- interface file. In particular, we get the rough match info from the iface --- (instead of computing it here). -mkImportedFamInst :: Name -- Name of the family - -> [Maybe Name] -- Rough match info - -> CoAxiom Unbranched -- Axiom introduced - -> FamInst -- Resulting family instance -mkImportedFamInst fam mb_tcs axiom - = FamInst { - fi_fam = fam, - fi_tcs = mb_tcs, - fi_tvs = tvs, - fi_cvs = cvs, - fi_tys = tys, - fi_rhs = rhs, - fi_axiom = axiom, - fi_flavor = flavor } - where - -- See Note [Lazy axiom match] - ~(CoAxBranch { cab_lhs = tys - , cab_tvs = tvs - , cab_cvs = cvs - , cab_rhs = rhs }) = coAxiomSingleBranch axiom - - -- Derive the flavor for an imported FamInst rather disgustingly - -- Maybe we should store it in the IfaceFamInst? - flavor = case splitTyConApp_maybe rhs of - Just (tc, _) - | Just ax' <- tyConFamilyCoercion_maybe tc - , ax' == axiom - -> DataFamilyInst tc - _ -> SynFamilyInst - -{- -************************************************************************ -* * - FamInstEnv -* * -************************************************************************ - -Note [FamInstEnv] -~~~~~~~~~~~~~~~~~ -A FamInstEnv maps a family name to the list of known instances for that family. - -The same FamInstEnv includes both 'data family' and 'type family' instances. -Type families are reduced during type inference, but not data families; -the user explains when to use a data family instance by using constructors -and pattern matching. - -Nevertheless it is still useful to have data families in the FamInstEnv: - - - For finding overlaps and conflicts - - - For finding the representation type...see FamInstEnv.topNormaliseType - and its call site in Simplify - - - In standalone deriving instance Eq (T [Int]) we need to find the - representation type for T [Int] - -Note [Varying number of patterns for data family axioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For data families, the number of patterns may vary between instances. -For example - data family T a b - data instance T Int a = T1 a | T2 - data instance T Bool [a] = T3 a - -Then we get a data type for each instance, and an axiom: - data TInt a = T1 a | T2 - data TBoolList a = T3 a - - axiom ax7 :: T Int ~ TInt -- Eta-reduced - axiom ax8 a :: T Bool [a] ~ TBoolList a - -These two axioms for T, one with one pattern, one with two; -see Note [Eta reduction for data families] - -Note [FamInstEnv determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We turn FamInstEnvs into a list in some places that don't directly affect -the ABI. That happens in family consistency checks and when producing output -for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard -to tell what it affects without following a chain of functions. It's also -easy to accidentally make that nondeterminism affect the ABI. Furthermore -the envs should be relatively small, so it should be free to use deterministic -maps here. Testing with nofib and validate detected no difference between -UniqFM and UniqDFM. -See Note [Deterministic UniqFM]. --} - -type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances - -- See Note [FamInstEnv] - -- See Note [FamInstEnv determinism] - -type FamInstEnvs = (FamInstEnv, FamInstEnv) - -- External package inst-env, Home-package inst-env - -newtype FamilyInstEnv - = FamIE [FamInst] -- The instances for a particular family, in any order - -instance Outputable FamilyInstEnv where - ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) - --- INVARIANTS: --- * The fs_tvs are distinct in each FamInst --- of a range value of the map (so we can safely unify them) - -emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) -emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) - -emptyFamInstEnv :: FamInstEnv -emptyFamInstEnv = emptyUDFM - -famInstEnvElts :: FamInstEnv -> [FamInst] -famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] - -- See Note [FamInstEnv determinism] - -famInstEnvSize :: FamInstEnv -> Int -famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 - -- It's OK to use nonDetFoldUDFM here since we're just computing the - -- size. - -familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] -familyInstances (pkg_fie, home_fie) fam - = get home_fie ++ get pkg_fie - where - get env = case lookupUDFM env fam of - Just (FamIE insts) -> insts - Nothing -> [] - -extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv -extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis - -extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env - ins_item@(FamInst {fi_fam = cls_nm}) - = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) - where - add (FamIE items) _ = FamIE (ins_item:items) - -{- -************************************************************************ -* * - Compatibility -* * -************************************************************************ - -Note [Apartness] -~~~~~~~~~~~~~~~~ -In dealing with closed type families, we must be able to check that one type -will never reduce to another. This check is called /apartness/. The check -is always between a target (which may be an arbitrary type) and a pattern. -Here is how we do it: - -apart(target, pattern) = not (unify(flatten(target), pattern)) - -where flatten (implemented in flattenTys, below) converts all type-family -applications into fresh variables. (See Note [Flattening].) - -Note [Compatibility] -~~~~~~~~~~~~~~~~~~~~ -Two patterns are /compatible/ if either of the following conditions hold: -1) The patterns are apart. -2) The patterns unify with a substitution S, and their right hand sides -equal under that substitution. - -For open type families, only compatible instances are allowed. For closed -type families, the story is slightly more complicated. Consider the following: - -type family F a where - F Int = Bool - F a = Int - -g :: Show a => a -> F a -g x = length (show x) - -Should that type-check? No. We need to allow for the possibility that 'a' -might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int -only when we can be sure that 'a' is not Int. - -To achieve this, after finding a possible match within the equations, we have to -go back to all previous equations and check that, under the -substitution induced by the match, other branches are surely apart. (See -Note [Apartness].) This is similar to what happens with class -instance selection, when we need to guarantee that there is only a match and -no unifiers. The exact algorithm is different here because the -potentially-overlapping group is closed. - -As another example, consider this: - -type family G x where - G Int = Bool - G a = Double - -type family H y --- no instances - -Now, we want to simplify (G (H Char)). We can't, because (H Char) might later -simplify to be Int. So, (G (H Char)) is stuck, for now. - -While everything above is quite sound, it isn't as expressive as we'd like. -Consider this: - -type family J a where - J Int = Int - J a = a - -Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if -b is instantiated with Int, but the RHSs coincide there, so it's all OK. - -So, the rule is this: when looking up a branch in a closed type family, we -find a branch that matches the target, but then we make sure that the target -is apart from every previous *incompatible* branch. We don't check the -branches that are compatible with the matching branch, because they are either -irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). - -Note [Compatibility of eta-reduced axioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In newtype instances of data families we eta-reduce the axioms, -See Note [Eta reduction for data families] in FamInstEnv. This means that -we sometimes need to test compatibility of two axioms that were eta-reduced to -different degrees, e.g.: - - -data family D a b c -newtype instance D a Int c = DInt (Maybe a) - -- D a Int ~ Maybe - -- lhs = [a, Int] -newtype instance D Bool Int Char = DIntChar Float - -- D Bool Int Char ~ Float - -- lhs = [Bool, Int, Char] - -These are obviously incompatible. We could detect this by saturating -(eta-expanding) the shorter LHS with fresh tyvars until the lists are of -equal length, but instead we can just remove the tail of the longer list, as -those types will simply unify with the freshly introduced tyvars. - -By doing this, in case the LHS are unifiable, the yielded substitution won't -mention the tyvars that appear in the tail we dropped off, and we might try -to test equality RHSes of different kinds, but that's fine since this case -occurs only for data families, where the RHS is a unique tycon and the equality -fails anyway. --} - --- See Note [Compatibility] -compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool -compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 - -- See Note [Compatibility of eta-reduced axioms] - in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of - SurelyApart -> True - Unifiable subst - | Type.substTyAddInScope subst rhs1 `eqType` - Type.substTyAddInScope subst rhs2 - -> True - _ -> False - --- | Result of testing two type family equations for injectiviy. -data InjectivityCheckResult - = InjectivityAccepted - -- ^ Either RHSs are distinct or unification of RHSs leads to unification of - -- LHSs - | InjectivityUnified CoAxBranch CoAxBranch - -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for - -- closed type families where equation after unification might be - -- overlpapped (in which case it is OK if they don't unify). Constructor - -- stores axioms after unification. - --- | Check whether two type family axioms don't violate injectivity annotation. -injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch - -> InjectivityCheckResult -injectiveBranches injectivity - ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - -- See Note [Verifying injectivity annotation], case 1. - = let getInjArgs = filterByList injectivity - in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification - Nothing -> InjectivityAccepted - -- RHS are different, so equations are injective. - -- This is case 1A from Note [Verifying injectivity annotation] - Just subst -> -- RHS unify under a substitution - let lhs1Subst = Type.substTys subst (getInjArgs lhs1) - lhs2Subst = Type.substTys subst (getInjArgs lhs2) - -- If LHSs are equal under the substitution used for RHSs then this pair - -- of equations does not violate injectivity annotation. If LHSs are not - -- equal under that substitution then this pair of equations violates - -- injectivity annotation, but for closed type families it still might - -- be the case that one LHS after substitution is unreachable. - in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. - then InjectivityAccepted - else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 - , cab_rhs = Type.substTy subst rhs1 }) - ( ax2 { cab_lhs = Type.substTys subst lhs2 - , cab_rhs = Type.substTy subst rhs2 }) - -- payload of InjectivityUnified used only for check 1B2, only - -- for closed type families - --- takes a CoAxiom with unknown branch incompatibilities and computes --- the compatibilities --- See Note [Storing compatibility] in CoAxiom -computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] -computeAxiomIncomps branches - = snd (mapAccumL go [] branches) - where - go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) - go prev_brs cur_br - = (cur_br : prev_brs, new_br) - where - new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } - - mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] - mk_incomps prev_brs cur_br - = filter (not . compatibleBranches cur_br) prev_brs - -{- -************************************************************************ -* * - Constructing axioms - These functions are here because tidyType / tcUnifyTysFG - are not available in CoAxiom - - Also computeAxiomIncomps is too sophisticated for CoAxiom -* * -************************************************************************ - -Note [Tidy axioms when we build them] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Like types and classes, we build axioms fully quantified over all -their variables, and tidy them when we build them. For example, -we print out axioms and don't want to print stuff like - F k k a b = ... -Instead we must tidy those kind variables. See #7524. - -We could instead tidy when we print, but that makes it harder to get -things like injectivity errors to come out right. Danger of - Type family equation violates injectivity annotation. - Kind variable ‘k’ cannot be inferred from the right-hand side. - In the type family equation: - PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 - -Note [Always number wildcard types in CoAxBranch] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example (from the DataFamilyInstanceLHS test case): - - data family Sing (a :: k) - data instance Sing (_ :: MyKind) where - SingA :: Sing A - SingB :: Sing B - -If we're not careful during tidying, then when this program is compiled with --ddump-types, we'll get the following information: - - COERCION AXIOMS - axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ - -It's misleading to have a wildcard type appearing on the RHS like -that. To avoid this issue, when building a CoAxiom (which is what eventually -gets printed above), we tidy all the variables in an env that already contains -'_'. Thus, any variable named '_' will be renamed, giving us the nicer output -here: - - COERCION AXIOMS - axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 - -Which is at least legal syntax. - -See also Note [CoAxBranch type variables] in CoAxiom; note that we -are tidying (changing OccNames only), not freshening, in accordance with -that Note. --} - --- all axiom roles are Nominal, as this is only used with type families -mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars - -> [TyVar] -- Extra eta tyvars - -> [CoVar] -- possibly stale covars - -> [Type] -- LHS patterns - -> Type -- RHS - -> [Role] - -> SrcSpan - -> CoAxBranch -mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc - = CoAxBranch { cab_tvs = tvs' - , cab_eta_tvs = eta_tvs' - , cab_cvs = cvs' - , cab_lhs = tidyTypes env lhs - , cab_roles = roles - , cab_rhs = tidyType env rhs - , cab_loc = loc - , cab_incomps = placeHolderIncomps } - where - (env1, tvs') = tidyVarBndrs init_tidy_env tvs - (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs - (env, cvs') = tidyVarBndrs env2 cvs - -- See Note [Tidy axioms when we build them] - -- See also Note [CoAxBranch type variables] in CoAxiom - - init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] - init_tidy_env = mkEmptyTidyEnv init_occ_env - -- See Note [Always number wildcard types in CoAxBranch] - --- all of the following code is here to avoid mutual dependencies with --- Coercion -mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched -mkBranchedCoAxiom ax_name fam_tc branches - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = Nominal - , co_ax_implicit = False - , co_ax_branches = manyBranches (computeAxiomIncomps branches) } - -mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched -mkUnbranchedCoAxiom ax_name fam_tc branch - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = Nominal - , co_ax_implicit = False - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - -mkSingleCoAxiom :: Role -> Name - -> [TyVar] -> [TyVar] -> [CoVar] - -> TyCon -> [Type] -> Type - -> CoAxiom Unbranched --- Make a single-branch CoAxiom, including making the branch itself --- Used for both type family (Nominal) and data family (Representational) --- axioms, hence passing in the Role -mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = role - , co_ax_implicit = False - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - where - branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty - (map (const Nominal) tvs) - (getSrcSpan ax_name) - --- | Create a coercion constructor (axiom) suitable for the given --- newtype 'TyCon'. The 'Name' should be that of a new coercion --- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and --- the type the appropriate right hand side of the @newtype@, with --- the free variables a subset of those 'TyVar's. -mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched -mkNewTypeCoAxiom name tycon tvs roles rhs_ty - = CoAxiom { co_ax_unique = nameUnique name - , co_ax_name = name - , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon - , co_ax_role = Representational - , co_ax_tc = tycon - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - where - branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty - roles (getSrcSpan name) - -{- -************************************************************************ -* * - Looking up a family instance -* * -************************************************************************ - -@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. -Multiple matches are only possible in case of type families (not data -families), and then, it doesn't matter which match we choose (as the -instances are guaranteed confluent). - -We return the matching family instances and the type instance at which it -matches. For example, if we lookup 'T [Int]' and have a family instance - - data instance T [a] = .. - -desugared to - - data :R42T a = .. - coe :Co:R42T a :: T [a] ~ :R42T a - -we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. --} - --- when matching a type family application, we get a FamInst, --- and the list of types the axiom should be applied to -data FamInstMatch = FamInstMatch { fim_instance :: FamInst - , fim_tys :: [Type] - , fim_cos :: [Coercion] - } - -- See Note [Over-saturated matches] - -instance Outputable FamInstMatch where - ppr (FamInstMatch { fim_instance = inst - , fim_tys = tys - , fim_cos = cos }) - = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos - -lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] -lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc - = get pkg_ie ++ get home_ie - where - get ie = case lookupUDFM ie fam_tc of - Nothing -> [] - Just (FamIE fis) -> fis - -lookupFamInstEnv - :: FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnv - = lookup_fam_inst_env match - where - match _ _ tpl_tys tys = tcMatchTys tpl_tys tys - -lookupFamInstEnvConflicts - :: FamInstEnvs - -> FamInst -- Putative new instance - -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) --- E.g. when we are about to add --- f : type instance F [a] = a->a --- we do (lookupFamInstConflicts f [b]) --- to find conflicting matches --- --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) - = lookup_fam_inst_env my_unify envs fam tys - where - (fam, tys) = famInstSplitLHS fam_inst - -- In example above, fam tys' = F [b] - - my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, - (ppr fam <+> ppr tys) $$ - (ppr tpl_tvs <+> ppr tpl_tys) ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch - then Nothing - else Just noSubst - -- Note [Family instance overlap conflicts] - - noSubst = panic "lookupFamInstEnvConflicts noSubst" - new_branch = coAxiomSingleBranch new_axiom - --------------------------------------------------------------------------------- --- Type family injectivity checking bits -- --------------------------------------------------------------------------------- - -{- Note [Verifying injectivity annotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Injectivity means that the RHS of a type family uniquely determines the LHS (see -Note [Type inference for type families with injectivity]). The user informs us about -injectivity using an injectivity annotation and it is GHC's task to verify that -this annotation is correct w.r.t. type family equations. Whenever we see a new -equation of a type family we need to make sure that adding this equation to the -already known equations of a type family does not violate the injectivity annotation -supplied by the user (see Note [Injectivity annotation]). Of course if the type -family has no injectivity annotation then no check is required. But if a type -family has injectivity annotation we need to make sure that the following -conditions hold: - -1. For each pair of *different* equations of a type family, one of the following - conditions holds: - - A: RHSs are different. (Check done in FamInstEnv.injectiveBranches) - - B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution - then it must be possible to unify the LHSs under the same substitution. - Example: - - type family FunnyId a = r | r -> a - type instance FunnyId Int = Int - type instance FunnyId a = a - - RHSs of these two equations unify under [ a |-> Int ] substitution. - Under this substitution LHSs are equal therefore these equations don't - violate injectivity annotation. (Check done in FamInstEnv.injectiveBranches) - - B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some - substitution then either the LHSs unify under the same substitution or - the LHS of the latter equation is overlapped by earlier equations. - Example 1: - - type family SwapIntChar a = r | r -> a where - SwapIntChar Int = Char - SwapIntChar Char = Int - SwapIntChar a = a - - Say we are checking the last two equations. RHSs unify under [ a |-> - Int ] substitution but LHSs don't. So we apply the substitution to LHS - of last equation and check whether it is overlapped by any of previous - equations. Since it is overlapped by the first equation we conclude - that pair of last two equations does not violate injectivity - annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts) - - A special case of B is when RHSs unify with an empty substitution ie. they - are identical. - - If any of the above two conditions holds we conclude that the pair of - equations does not violate injectivity annotation. But if we find a pair - of equations where neither of the above holds we report that this pair - violates injectivity annotation because for a given RHS we don't have a - unique LHS. (Note that (B) actually implies (A).) - - Note that we only take into account these LHS patterns that were declared - as injective. - -2. If an RHS of a type family equation is a bare type variable then - all LHS variables (including implicit kind variables) also have to be bare. - In other words, this has to be a sole equation of that type family and it has - to cover all possible patterns. So for example this definition will be - rejected: - - type family W1 a = r | r -> a - type instance W1 [a] = a - - If it were accepted we could call `W1 [W1 Int]`, which would reduce to - `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, - which is bogus. Checked FamInst.bareTvInRHSViolated. - -3. If the RHS of a type family equation is a type family application then the type - family is rejected as not injective. This is checked by FamInst.isTFHeaded. - -4. If a LHS type variable that is declared as injective is not mentioned in an - injective position in the RHS then the type family is rejected as not - injective. "Injective position" means either an argument to a type - constructor or argument to a type family on injective position. - There are subtleties here. See Note [Coverage condition for injective type families] - in FamInst. - -Check (1) must be done for all family instances (transitively) imported. Other -checks (2-4) should be done just for locally written equations, as they are checks -involving just a single equation, not about interactions. Doing the other checks for -imported equations led to #17405, as the behavior of check (4) depends on --XUndecidableInstances (see Note [Coverage condition for injective type families] in -FamInst), which may vary between modules. - -See also Note [Injective type families] in TyCon --} - - --- | Check whether an open type family equation can be added to already existing --- instance environment without causing conflicts with supplied injectivity --- annotations. Returns list of conflicting axioms (type instance --- declarations). -lookupFamInstEnvInjectivityConflicts - :: [Bool] -- injectivity annotation for this type family instance - -- INVARIANT: list contains at least one True value - -> FamInstEnvs -- all type instances seens so far - -> FamInst -- new type instance that we're checking - -> [CoAxBranch] -- conflicting instance declarations -lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) - fam_inst@(FamInst { fi_axiom = new_axiom }) - -- See Note [Verifying injectivity annotation]. This function implements - -- check (1.B1) for open type families described there. - = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie - where - fam = famInstTyCon fam_inst - new_branch = coAxiomSingleBranch new_axiom - - -- filtering function used by `lookup_inj_fam_conflicts` to check whether - -- a pair of equations conflicts with the injectivity annotation. - isInjConflict (FamInst { fi_axiom = old_axiom }) - | InjectivityAccepted <- - injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch - = False -- no conflict - | otherwise = True - - lookup_inj_fam_conflicts ie - | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam - = map (coAxiomSingleBranch . fi_axiom) $ - filter isInjConflict insts - | otherwise = [] - - --------------------------------------------------------------------------------- --- Type family overlap checking bits -- --------------------------------------------------------------------------------- - -{- -Note [Family instance overlap conflicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In the case of data family instances, any overlap is fundamentally a - conflict (as these instances imply injective type mappings). - -- In the case of type family instances, overlap is admitted as long as - the right-hand sides of the overlapping rules coincide under the - overlap substitution. eg - type instance F a Int = a - type instance F Int b = b - These two overlap on (F Int Int) but then both RHSs are Int, - so all is well. We require that they are syntactically equal; - anything else would be difficult to test for at this stage. --} - ------------------------------------------------------------- --- Might be a one-way match or a unifier -type MatchFun = FamInst -- The FamInst template - -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst - -> [Type] -- Target to match against - -> Maybe TCvSubst - -lookup_fam_inst_env' -- The worker, local to this module - :: MatchFun - -> FamInstEnv - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -lookup_fam_inst_env' match_fun ie fam match_tys - | isOpenFamilyTyCon fam - , Just (FamIE insts) <- lookupUDFM ie fam - = find insts -- The common case - | otherwise = [] - where - - find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs - , fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find rest - - -- Proper check - | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 - = (FamInstMatch { fim_instance = item - , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 - , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) - substCoVars subst tpl_cvs - }) - : find rest - - -- No match => try next - | otherwise - = find rest - where - (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys - - -- Precondition: the tycon is saturated (or over-saturated) - - -- Deal with over-saturation - -- See Note [Over-saturated matches] - split_tys tpl_tys - | isTypeFamilyTyCon fam - = pre_rough_split_tys - - | otherwise - = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys - rough_tcs = roughMatchTcs match_tys1 - in (rough_tcs, match_tys1, match_tys2) - - (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys - pre_rough_split_tys - = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) - -lookup_fam_inst_env -- The worker, local to this module - :: MatchFun - -> FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches - --- Precondition: the tycon is saturated (or over-saturated) - -lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys - = lookup_fam_inst_env' match_fun home_ie fam tys - ++ lookup_fam_inst_env' match_fun pkg_ie fam tys - -{- -Note [Over-saturated matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's ok to look up an over-saturated type constructor. E.g. - type family F a :: * -> * - type instance F (a,b) = Either (a->b) - -The type instance gives rise to a newtype TyCon (at a higher kind -which you can't do in Haskell!): - newtype FPair a b = FP (Either (a->b)) - -Then looking up (F (Int,Bool) Char) will return a FamInstMatch - (FPair, [Int,Bool,Char]) -The "extra" type argument [Char] just stays on the end. - -We handle data families and type families separately here: - - * For type families, all instances of a type family must have the - same arity, so we can precompute the split between the match_tys - and the overflow tys. This is done in pre_rough_split_tys. - - * For data family instances, though, we need to re-split for each - instance, because the breakdown might be different for each - instance. Why? Because of eta reduction; see - Note [Eta reduction for data families]. --} - --- checks if one LHS is dominated by a list of other branches --- in other words, if an application would match the first LHS, it is guaranteed --- to match at least one of the others. The RHSs are ignored. --- This algorithm is conservative: --- True -> the LHS is definitely covered by the others --- False -> no information --- It is currently (Oct 2012) used only for generating errors for --- inaccessible branches. If these errors go unreported, no harm done. --- This is defined here to avoid a dependency from CoAxiom to Unify -isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool -isDominatedBy branch branches - = or $ map match branches - where - lhs = coAxBranchLHS branch - match (CoAxBranch { cab_lhs = tys }) - = isJust $ tcMatchTys tys lhs - -{- -************************************************************************ -* * - Choosing an axiom application -* * -************************************************************************ - -The lookupFamInstEnv function does a nice job for *open* type families, -but we also need to handle closed ones when normalising a type: --} - -reduceTyFamApp_maybe :: FamInstEnvs - -> Role -- Desired role of result coercion - -> TyCon -> [Type] - -> Maybe (Coercion, Type) --- Attempt to do a *one-step* reduction of a type-family application --- but *not* newtypes --- Works on type-synonym families always; data-families only if --- the role we seek is representational --- It does *not* normalise the type arguments first, so this may not --- go as far as you want. If you want normalised type arguments, --- use normaliseTcArgs first. --- --- The TyCon can be oversaturated. --- Works on both open and closed families --- --- Always returns a *homogeneous* coercion -- type family reductions are always --- homogeneous -reduceTyFamApp_maybe envs role tc tys - | Phantom <- role - = Nothing - - | case role of - Representational -> isOpenFamilyTyCon tc - _ -> isOpenTypeFamilyTyCon tc - -- If we seek a representational coercion - -- (e.g. the call in topNormaliseType_maybe) then we can - -- unwrap data families as well as type-synonym families; - -- otherwise only type-synonym families - , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } - , fim_tys = inst_tys - , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys - -- NB: Allow multiple matches because of compatible overlap - - = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos - ty = coercionRKind co - in Just (co, ty) - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc - , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys - = let co = mkAxInstCo role ax ind inst_tys inst_cos - ty = coercionRKind co - in Just (co, ty) - - | Just ax <- isBuiltInSynFamTyCon_maybe tc - , Just (coax,ts,ty) <- sfMatchFam ax tys - = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) - in Just (co, ty) - - | otherwise - = Nothing - --- The axiom can be oversaturated. (Closed families only.) -chooseBranch :: CoAxiom Branched -> [Type] - -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args -chooseBranch axiom tys - = do { let num_pats = coAxiomNumPats axiom - (target_tys, extra_tys) = splitAt num_pats tys - branches = coAxiomBranches axiom - ; (ind, inst_tys, inst_cos) - <- findBranch (unMkBranches branches) target_tys - ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } - --- The axiom must *not* be oversaturated -findBranch :: Array BranchIndex CoAxBranch - -> [Type] - -> Maybe (BranchIndex, [Type], [Coercion]) - -- coercions relate requested types to returned axiom LHS at role N -findBranch branches target_tys - = foldr go Nothing (assocs branches) - where - go :: (BranchIndex, CoAxBranch) - -> Maybe (BranchIndex, [Type], [Coercion]) - -> Maybe (BranchIndex, [Type], [Coercion]) - go (index, branch) other - = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs - , cab_lhs = tpl_lhs - , cab_incomps = incomps }) = branch - in_scope = mkInScopeSet (unionVarSets $ - map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - -- See Note [Flattening] below - flattened_target = flattenTys in_scope target_tys - in case tcMatchTys tpl_lhs target_tys of - Just subst -- matching worked. now, check for apartness. - | apartnessCheck flattened_target branch - -> -- matching worked & we're apart from all incompatible branches. - -- success - ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) - Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) - - -- failure. keep looking - _ -> other - --- | Do an apartness check, as described in the "Closed Type Families" paper --- (POPL '14). This should be used when determining if an equation --- ('CoAxBranch') of a closed type family can be used to reduce a certain target --- type family application. -apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure - -- they're flattened! See Note [Flattening]. - -- (NB: This "flat" is a different - -- "flat" than is used in TcFlatten.) - -> CoAxBranch -- ^ the candidate equation we wish to use - -- Precondition: this matches the target - -> Bool -- ^ True <=> equation can fire -apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) - = all (isSurelyApart - . tcUnifyTysFG (const BindMe) flattened_target - . coAxBranchLHS) incomps - where - isSurelyApart SurelyApart = True - isSurelyApart _ = False - -{- -************************************************************************ -* * - Looking up a family instance -* * -************************************************************************ - -Note [Normalising types] -~~~~~~~~~~~~~~~~~~~~~~~~ -The topNormaliseType function removes all occurrences of type families -and newtypes from the top-level structure of a type. normaliseTcApp does -the type family lookup and is fairly straightforward. normaliseType is -a little more involved. - -The complication comes from the fact that a type family might be used in the -kind of a variable bound in a forall. We wish to remove this type family -application, but that means coming up with a fresh variable (with the new -kind). Thus, we need a substitution to be built up as we recur through the -type. However, an ordinary TCvSubst just won't do: when we hit a type variable -whose kind has changed during normalisation, we need both the new type -variable *and* the coercion. We could conjure up a new VarEnv with just this -property, but a usable substitution environment already exists: -LiftingContexts from the liftCoSubst family of functions, defined in Coercion. -A LiftingContext maps a type variable to a coercion and a coercion variable to -a pair of coercions. Let's ignore coercion variables for now. Because the -coercion a type variable maps to contains the destination type (via -coercionKind), we don't need to store that destination type separately. Thus, -a LiftingContext has what we need: a map from type variables to (Coercion, -Type) pairs. - -We also benefit because we can piggyback on the liftCoSubstVarBndr function to -deal with binders. However, I had to modify that function to work with this -application. Thus, we now have liftCoSubstVarBndrUsing, which takes -a function used to process the kind of the binder. We don't wish -to lift the kind, but instead normalise it. So, we pass in a callback function -that processes the kind of the binder. - -After that brilliant explanation of all this, I'm sure you've forgotten the -dangling reference to coercion variables. What do we do with those? Nothing at -all. The point of normalising types is to remove type family applications, but -there's no sense in removing these from coercions. We would just get back a -new coercion witnessing the equality between the same types as the original -coercion. Because coercions are irrelevant anyway, there is no point in doing -this. So, whenever we encounter a coercion, we just say that it won't change. -That's what the CoercionTy case is doing within normalise_type. - -Note [Normalisation and type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to be a bit careful about normalising in the presence of type -synonyms (#13035). Suppose S is a type synonym, and we have - S t1 t2 -If S is family-free (on its RHS) we can just normalise t1 and t2 and -reconstruct (S t1' t2'). Expanding S could not reveal any new redexes -because type families are saturated. - -But if S has a type family on its RHS we expand /before/ normalising -the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them -after expansion, and that can lead to /exponential/ behaviour; see #13035. - -Notice, though, that expanding first can in principle duplicate t1,t2, -which might contain redexes. I'm sure you could conjure up an exponential -case by that route too, but it hasn't happened in practice yet! --} - -topNormaliseType :: FamInstEnvs -> Type -> Type -topNormaliseType env ty = case topNormaliseType_maybe env ty of - Just (_co, ty') -> ty' - Nothing -> ty - -topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) - --- ^ Get rid of *outermost* (or toplevel) --- * type function redex --- * data family redex --- * newtypes --- returning an appropriate Representational coercion. Specifically, if --- topNormaliseType_maybe env ty = Just (co, ty') --- then --- (a) co :: ty ~R ty' --- (b) ty' is not a newtype, and is not a type-family or data-family redex --- --- However, ty' can be something like (Maybe (F ty)), where --- (F ty) is a redex. --- --- Always operates homogeneously: the returned type has the same kind as the --- original type, and the returned coercion is always homogeneous. -topNormaliseType_maybe env ty - = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty - ; return $ case mkind_co of - MRefl -> (co, nty) - MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co - final_co = mkCoherenceRightCo Representational nty - (mkSymCo kind_co) co - in (final_co, nty_casted) } - where - stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper - - combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) - - unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) - unwrapNewTypeStepper' rec_nts tc tys - = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys - - -- second coercion below is the kind coercion relating the original type's kind - -- to the normalised type's kind - tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) - tyFamStepper rec_nts tc tys -- Try to step a type/data family - = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in - case reduceTyFamApp_maybe env Representational tc ntys of - Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co) - _ -> NS_Done - ---------------- -normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) --- See comments on normaliseType for the arguments of this function -normaliseTcApp env role tc tys - = initNormM env role (tyCoVarsOfTypes tys) $ - normalise_tc_app tc tys - --- See Note [Normalising types] about the LiftingContext -normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) -normalise_tc_app tc tys - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , not (isFamFreeTyCon tc) -- Expand and try again - = -- A synonym with type families in the RHS - -- Expand and try again - -- See Note [Normalisation and type synonyms] - normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - - | isFamilyTyCon tc - = -- A type-family application - do { env <- getEnv - ; role <- getRole - ; (args_co, ntys, res_co) <- normalise_tc_args tc tys - ; case reduceTyFamApp_maybe env role tc ntys of - Just (first_co, ty') - -> do { (rest_co,nty) <- normalise_type ty' - ; return (assemble_result role nty - (args_co `mkTransCo` first_co `mkTransCo` rest_co) - res_co) } - _ -> -- No unique matching family instance exists; - -- we do not do anything - return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } - - | otherwise - = -- A synonym with no type families in the RHS; or data type etc - -- Just normalise the arguments and rebuild - do { (args_co, ntys, res_co) <- normalise_tc_args tc tys - ; role <- getRole - ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } - - where - assemble_result :: Role -- r, ambient role in NormM monad - -> Type -- nty, result type, possibly of changed kind - -> Coercion -- orig_ty ~r nty, possibly heterogeneous - -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) - -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) - -- where nty_casted has same kind as orig_ty - assemble_result r nty orig_to_nty kind_co - = ( final_co, nty_old_kind ) - where - nty_old_kind = nty `mkCastTy` mkSymCo kind_co - final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty - ---------------- --- | Normalise arguments to a tycon -normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances - -> Role -- ^ desired role of output coercion - -> TyCon -- ^ tc - -> [Type] -- ^ tys - -> (Coercion, [Type], CoercionN) - -- ^ co :: tc tys ~ tc new_tys - -- NB: co might not be homogeneous - -- last coercion :: kind(tc tys) ~ kind(tc new_tys) -normaliseTcArgs env role tc tys - = initNormM env role (tyCoVarsOfTypes tys) $ - normalise_tc_args tc tys - -normalise_tc_args :: TyCon -> [Type] -- tc tys - -> NormM (Coercion, [Type], CoercionN) - -- (co, new_tys), where - -- co :: tc tys ~ tc new_tys; might not be homogeneous - -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) -normalise_tc_args tc tys - = do { role <- getRole - ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys - ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } - ---------------- -normaliseType :: FamInstEnvs - -> Role -- desired role of coercion - -> Type -> (Coercion, Type) -normaliseType env role ty - = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty - -normalise_type :: Type -- old type - -> NormM (Coercion, Type) -- (coercion, new type), where - -- co :: old-type ~ new_type --- Normalise the input type, by eliminating *all* type-function redexes --- but *not* newtypes (which are visible to the programmer) --- Returns with Refl if nothing happens --- Does nothing to newtypes --- The returned coercion *must* be *homogeneous* --- See Note [Normalising types] --- Try not to disturb type synonyms if possible - -normalise_type ty - = go ty - where - go (TyConApp tc tys) = normalise_tc_app tc tys - go ty@(LitTy {}) = do { r <- getRole - ; return (mkReflCo r ty, ty) } - - go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] - - go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) - = do { (co1, nty1) <- go ty1 - ; (co2, nty2) <- go ty2 - ; r <- getRole - ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } - go (ForAllTy (Bndr tcvar vis) ty) - = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar - ; (co, nty) <- withLC lc' $ normalise_type ty - ; let tv2 = setTyVarKind tv' ki' - ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } - go (TyVarTy tv) = normalise_tyvar tv - go (CastTy ty co) - = do { (nco, nty) <- go ty - ; lc <- getLC - ; let co' = substRightCo lc co - ; return (castCoercionKind nco Nominal ty nty co co' - , mkCastTy nty co') } - go (CoercionTy co) - = do { lc <- getLC - ; r <- getRole - ; let right_co = substRightCo lc co - ; return ( mkProofIrrelCo r - (liftCoSubst Nominal lc (coercionType co)) - co right_co - , mkCoercionTy right_co ) } - - go_app_tys :: Type -- function - -> [Type] -- args - -> NormM (Coercion, Type) - -- cf. TcFlatten.flatten_app_ty_args - go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) - go_app_tys fun_ty arg_tys - = do { (fun_co, nfun) <- go fun_ty - ; case tcSplitTyConApp_maybe nfun of - Just (tc, xis) -> - do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) - -- flatten_app_ty_args avoids redundantly processing the xis, - -- but that's a much more performance-sensitive function. - -- This type normalisation is not called in a loop. - ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } - Nothing -> - do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) - (repeat Nominal) - arg_tys - ; role <- getRole - ; let nty = mkAppTys nfun nargs - nco = mkAppCos fun_co args_cos - nty_casted = nty `mkCastTy` mkSymCo res_co - final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco - ; return (final_co, nty_casted) } } - -normalise_args :: Kind -- of the function - -> [Role] -- roles at which to normalise args - -> [Type] -- args - -> NormM ([Coercion], [Type], Coercion) --- returns (cos, xis, res_co), where each xi is the normalised --- version of the corresponding type, each co is orig_arg ~ xi, --- and the res_co :: kind(f orig_args) ~ kind(f xis) --- NB: The xis might *not* have the same kinds as the input types, --- but the resulting application *will* be well-kinded --- cf. TcFlatten.flatten_args_slow -normalise_args fun_ki roles args - = do { normed_args <- zipWithM normalise1 roles args - ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args - ; return (map mkSymCo cos, xis, mkSymCo res_co) } - where - (ki_binders, inner_ki) = splitPiTys fun_ki - fvs = tyCoVarsOfTypes args - - -- flattener conventions are different from ours - impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) - impedance_match action = do { (co, ty) <- action - ; return (ty, mkSymCo co) } - - normalise1 role ty - = impedance_match $ withRole role $ normalise_type ty - -normalise_tyvar :: TyVar -> NormM (Coercion, Type) -normalise_tyvar tv - = ASSERT( isTyVar tv ) - do { lc <- getLC - ; r <- getRole - ; return $ case liftCoSubstTyVar lc r tv of - Just co -> (co, coercionRKind co) - Nothing -> (mkReflCo r ty, ty) } - where ty = mkTyVarTy tv - -normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) -normalise_var_bndr tcvar - -- works for both tvar and covar - = do { lc1 <- getLC - ; env <- getEnv - ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal - ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } - --- | a monad for the normalisation functions, reading 'FamInstEnvs', --- a 'LiftingContext', and a 'Role'. -newtype NormM a = NormM { runNormM :: - FamInstEnvs -> LiftingContext -> Role -> a } - deriving (Functor) - -initNormM :: FamInstEnvs -> Role - -> TyCoVarSet -- the in-scope variables - -> NormM a -> a -initNormM env role vars (NormM thing_inside) - = thing_inside env lc role - where - in_scope = mkInScopeSet vars - lc = emptyLiftingContext in_scope - -getRole :: NormM Role -getRole = NormM (\ _ _ r -> r) - -getLC :: NormM LiftingContext -getLC = NormM (\ _ lc _ -> lc) - -getEnv :: NormM FamInstEnvs -getEnv = NormM (\ env _ _ -> env) - -withRole :: Role -> NormM a -> NormM a -withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r - -withLC :: LiftingContext -> NormM a -> NormM a -withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r - -instance Monad NormM where - ma >>= fmb = NormM $ \env lc r -> - let a = runNormM ma env lc r in - runNormM (fmb a) env lc r - -instance Applicative NormM where - pure x = NormM $ \ _ _ _ -> x - (<*>) = ap - -{- -************************************************************************ -* * - Flattening -* * -************************************************************************ - -Note [Flattening] -~~~~~~~~~~~~~~~~~ -As described in "Closed type families with overlapping equations" -http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf -we need to flatten core types before unifying them, when checking for "surely-apart" -against earlier equations of a closed type family. -Flattening means replacing all top-level uses of type functions with -fresh variables, *taking care to preserve sharing*. That is, the type -(Either (F a b) (F a b)) should flatten to (Either c c), never (Either -c d). - -Here is a nice example of why it's all necessary: - - type family F a b where - F Int Bool = Char - F a b = Double - type family G a -- open, no instances - -How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, -while the second equation does. But, before reducing, we must make sure that the -target can never become (F Int Bool). Well, no matter what G Float becomes, it -certainly won't become *both* Int and Bool, so indeed we're safe reducing -(F (G Float) (G Float)) to Double. - -This is necessary not only to get more reductions (which we might be -willing to give up on), but for substitutivity. If we have (F x x), we -can see that (F x x) can reduce to Double. So, it had better be the -case that (F blah blah) can reduce to Double, no matter what (blah) -is! Flattening as done below ensures this. - -The algorithm works by building up a TypeMap TyVar, mapping -type family applications to fresh variables. This mapping must -be threaded through all the function calls, as any entry in -the mapping must be propagated to all future nodes in the tree. - -The algorithm also must track the set of in-scope variables, in -order to make fresh variables as it flattens. (We are far from a -source of fresh Uniques.) See Wrinkle 2, below. - -There are wrinkles, of course: - -1. The flattening algorithm must account for the possibility - of inner `forall`s. (A `forall` seen here can happen only - because of impredicativity. However, the flattening operation - is an algorithm in Core, which is impredicative.) - Suppose we have (forall b. F b) -> (forall b. F b). Of course, - those two bs are entirely unrelated, and so we should certainly - not flatten the two calls F b to the same variable. Instead, they - must be treated separately. We thus carry a substitution that - freshens variables; we must apply this substitution (in - `coreFlattenTyFamApp`) before looking up an application in the environment. - Note that the range of the substitution contains only TyVars, never anything - else. - - For the sake of efficiency, we only apply this substitution when absolutely - necessary. Namely: - - * We do not perform the substitution at all if it is empty. - * We only need to worry about the arguments of a type family that are within - the arity of said type family, so we can get away with not applying the - substitution to any oversaturated type family arguments. - * Importantly, we do /not/ achieve this substitution by recursively - flattening the arguments, as this would be wrong. Consider `F (G a)`, - where F and G are type families. We might decide that `F (G a)` flattens - to `beta`. Later, the substitution is non-empty (but does not map `a`) and - so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, - `F gamma` is unknown, and so we flatten it to `delta`, but it really - should have been `beta`! Argh! - - Moral of the story: instead of flattening the arguments, just substitute - them directly. - -2. There are two different reasons we might add a variable - to the in-scope set as we work: - - A. We have just invented a new flattening variable. - B. We have entered a `forall`. - - Annoying here is that in-scope variable source (A) must be - threaded through the calls. For example, consider (F b -> forall c. F c). - Suppose that, when flattening F b, we invent a fresh variable c. - Now, when we encounter (forall c. F c), we need to know c is already in - scope so that we locally rename c to c'. However, if we don't thread through - the in-scope set from one argument of (->) to the other, we won't know this - and might get very confused. - - In contrast, source (B) increases only as we go deeper, as in-scope sets - normally do. However, even here we must be careful. The TypeMap TyVar that - contains mappings from type family applications to freshened variables will - be threaded through both sides of (forall b. F b) -> (forall b. F b). We - thus must make sure that the two `b`s don't get renamed to the same b1. (If - they did, then looking up `F b1` would yield the same flatten var for - each.) So, even though `forall`-bound variables should really be in the - in-scope set only when they are in scope, we retain these variables even - outside of their scope. This ensures that, if we encounter a fresh - `forall`-bound b, we will rename it to b2, not b1. Note that keeping a - larger in-scope set than strictly necessary is always OK, as in-scope sets - are only ever used to avoid collisions. - - Sadly, the freshening substitution described in (1) really musn't bind - variables outside of their scope: note that its domain is the *unrenamed* - variables. This means that the substitution gets "pushed down" (like a - reader monad) while the in-scope set gets threaded (like a state monad). - Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; - instead, we just carry a TvSubstEnv down, tying it to the InScopeSet - traveling separately as necessary. - -3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: - - type family F ty_1 ... ty_k :: res_k - - It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a - flattening skolem. But we must instead flatten it to - `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the - type family. - - Why is this better? Consider the following concrete example from #16995: - - type family Param :: Type -> Type - - type family LookupParam (a :: Type) :: Type where - LookupParam (f Char) = Bool - LookupParam x = Int - - foo :: LookupParam (Param ()) - foo = 42 - - In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to - `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if - `alpha` is apart from `f Char`, so it won't fall through to the second - equation. But since the `Param` type family has arity 0, we can instead - flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is - apart from `f Char`, permitting the second equation to be reached. - - Not only does this allow more programs to be accepted, it's also important - for correctness. Not doing this was the root cause of the Core Lint error - in #16995. - -flattenTys is defined here because of module dependencies. --} - -data FlattenEnv - = FlattenEnv { fe_type_map :: TypeMap TyVar - -- domain: exactly-saturated type family applications - -- range: fresh variables - , fe_in_scope :: InScopeSet } - -- See Note [Flattening] - -emptyFlattenEnv :: InScopeSet -> FlattenEnv -emptyFlattenEnv in_scope - = FlattenEnv { fe_type_map = emptyTypeMap - , fe_in_scope = in_scope } - -updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv -updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } - -flattenTys :: InScopeSet -> [Type] -> [Type] --- See Note [Flattening] --- NB: the returned types may mention fresh type variables, --- arising from the flattening. We don't return the --- mapping from those fresh vars to the ty-fam --- applications they stand for (we could, but no need) -flattenTys in_scope tys - = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys - -coreFlattenTys :: TvSubstEnv -> FlattenEnv - -> [Type] -> (FlattenEnv, [Type]) -coreFlattenTys subst = mapAccumL (coreFlattenTy subst) - -coreFlattenTy :: TvSubstEnv -> FlattenEnv - -> Type -> (FlattenEnv, Type) -coreFlattenTy subst = go - where - go env ty | Just ty' <- coreView ty = go env ty' - - go env (TyVarTy tv) - | Just ty <- lookupVarEnv subst tv = (env, ty) - | otherwise = let (env', ki) = go env (tyVarKind tv) in - (env', mkTyVarTy $ setTyVarKind tv ki) - go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, AppTy ty1' ty2') - go env (TyConApp tc tys) - -- NB: Don't just check if isFamilyTyCon: this catches *data* families, - -- which are generative and thus can be preserved during flattening - | not (isGenerativeTyCon tc Nominal) - = coreFlattenTyFamApp subst env tc tys - - | otherwise - = let (env', tys') = coreFlattenTys subst env tys in - (env', mkTyConApp tc tys') - - go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) - = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, ty { ft_arg = ty1', ft_res = ty2' }) - - go env (ForAllTy (Bndr tv vis) ty) - = let (env1, subst', tv') = coreFlattenVarBndr subst env tv - (env2, ty') = coreFlattenTy subst' env1 ty in - (env2, ForAllTy (Bndr tv' vis) ty') - - go env ty@(LitTy {}) = (env, ty) - - go env (CastTy ty co) - = let (env1, ty') = go env ty - (env2, co') = coreFlattenCo subst env1 co in - (env2, CastTy ty' co') - - go env (CoercionTy co) - = let (env', co') = coreFlattenCo subst env co in - (env', CoercionTy co') - --- when flattening, we don't care about the contents of coercions. --- so, just return a fresh variable of the right (flattened) type -coreFlattenCo :: TvSubstEnv -> FlattenEnv - -> Coercion -> (FlattenEnv, Coercion) -coreFlattenCo subst env co - = (env2, mkCoVarCo covar) - where - (env1, kind') = coreFlattenTy subst env (coercionType co) - covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' - -- Add the covar to the FlattenEnv's in-scope set. - -- See Note [Flattening], wrinkle 2A. - env2 = updateInScopeSet env1 (flip extendInScopeSet covar) - -coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv - -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) -coreFlattenVarBndr subst env tv - = (env2, subst', tv') - where - -- See Note [Flattening], wrinkle 2B. - kind = varType tv - (env1, kind') = coreFlattenTy subst env kind - tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') - subst' = extendVarEnv subst tv (mkTyVarTy tv') - env2 = updateInScopeSet env1 (flip extendInScopeSet tv') - -coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv - -> TyCon -- type family tycon - -> [Type] -- args, already flattened - -> (FlattenEnv, Type) -coreFlattenTyFamApp tv_subst env fam_tc fam_args - = case lookupTypeMap type_map fam_ty of - Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') - Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc - tv = uniqAway in_scope $ - mkTyVar tyvar_name (typeKind fam_ty) - - ty' = mkAppTys (mkTyVarTy tv) leftover_args' - env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv - , fe_in_scope = extendInScopeSet in_scope tv } - in (env'', ty') - where - arity = tyConArity fam_tc - tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv - (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) - splitAt arity fam_args - -- Apply the substitution before looking up an application in the - -- environment. See Note [Flattening], wrinkle 1. - -- NB: substTys short-cuts the common case when the substitution is empty. - sat_fam_args' = substTys tcv_subst sat_fam_args - (env', leftover_args') = coreFlattenTys tv_subst env leftover_args - -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], - -- wrinkle 3), so we split it into the arguments needed to saturate it - -- (sat_fam_args') and the rest (leftover_args') - fam_ty = mkTyConApp fam_tc sat_fam_args' - FlattenEnv { fe_type_map = type_map - , fe_in_scope = in_scope } = env' - -mkFlattenFreshTyName :: Uniquable a => a -> Name -mkFlattenFreshTyName unq - = mkSysTvName (getUnique unq) (fsLit "flt") - -mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar -mkFlattenFreshCoVar in_scope kind - = let uniq = unsafeGetFreshLocalUnique in_scope - name = mkSystemVarName uniq (fsLit "flc") - in mkCoVar name kind diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs deleted file mode 100644 --- a/compiler/types/InstEnv.hs +++ /dev/null @@ -1,1030 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[InstEnv]{Utilities for typechecking instance declarations} - -The bits common to TcInstDcls and TcDeriv. --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module InstEnv ( - DFunId, InstMatch, ClsInstLookupResult, - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, - instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, - instanceDFunId, updateClsInstDFun, instanceRoughTcs, - fuzzyClsInstCmp, orphNamesOfClsInst, - - InstEnvs(..), VisibleOrphanModules, InstEnv, - emptyInstEnv, extendInstEnv, - deleteFromInstEnv, deleteDFunFromInstEnv, - identicalClsInstHead, - extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, - memberInstEnv, - instIsVisible, - classInstances, instanceBindFun, - instanceCantMatch, roughMatchTcs, - isOverlappable, isOverlapping, isIncoherent - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcType -- InstEnv is really part of the type checker, - -- and depends on TcType in many ways -import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) -import Module -import Class -import Var -import VarSet -import Name -import NameSet -import Unify -import Outputable -import ErrUtils -import BasicTypes -import UniqDFM -import Util -import Id -import Data.Data ( Data ) -import Data.Maybe ( isJust, isNothing ) - -{- -************************************************************************ -* * - ClsInst: the data type for type-class instances -* * -************************************************************************ --} - --- | A type-class instance. Note that there is some tricky laziness at work --- here. See Note [ClsInst laziness and the rough-match fields] for more --- details. -data ClsInst - = ClsInst { -- Used for "rough matching"; see - -- Note [ClsInst laziness and the rough-match fields] - -- INVARIANT: is_tcs = roughMatchTcs is_tys - is_cls_nm :: Name -- ^ Class name - , is_tcs :: [Maybe Name] -- ^ Top of type args - - -- | @is_dfun_name = idName . is_dfun@. - -- - -- We use 'is_dfun_name' for the visibility check, - -- 'instIsVisible', which needs to know the 'Module' which the - -- dictionary is defined in. However, we cannot use the 'Module' - -- attached to 'is_dfun' since doing so would mean we would - -- potentially pull in an entire interface file unnecessarily. - -- This was the cause of #12367. - , is_dfun_name :: Name - - -- Used for "proper matching"; see Note [Proper-match fields] - , is_tvs :: [TyVar] -- Fresh template tyvars for full match - -- See Note [Template tyvars are fresh] - , is_cls :: Class -- The real class - , is_tys :: [Type] -- Full arg types (mentioning is_tvs) - -- INVARIANT: is_dfun Id has type - -- forall is_tvs. (...) => is_cls is_tys - -- (modulo alpha conversion) - - , is_dfun :: DFunId -- See Note [Haddock assumptions] - - , is_flag :: OverlapFlag -- See detailed comments with - -- the decl of BasicTypes.OverlapFlag - , is_orphan :: IsOrphan - } - deriving Data - --- | A fuzzy comparison function for class instances, intended for sorting --- instances before displaying them to the user. -fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering -fuzzyClsInstCmp x y = - stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` - mconcat (map cmp (zip (is_tcs x) (is_tcs y))) - where - cmp (Nothing, Nothing) = EQ - cmp (Nothing, Just _) = LT - cmp (Just _, Nothing) = GT - cmp (Just x, Just y) = stableNameCmp x y - -isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool -isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) -isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) -isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) - -{- -Note [ClsInst laziness and the rough-match fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is -otherwise unused in the program. Then it's stupid to load B.hi, the data type -declaration for B.T -- and perhaps further instance declarations! - -We avoid this as follows: - -* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's - content. - -* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys - contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we - poke any of these fields we'll typecheck the DFunId declaration, and hence - pull in interfaces that it refers to. See Note [Proper-match fields]. - -* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and - is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking - inside the DFunId. The rough-match fields allow us to say "definitely does not - match", based only on Names. - - This laziness is very important; see #12367. Try hard to avoid pulling on - the structured fields unless you really need the instance. - -* Another place to watch is InstEnv.instIsVisible, which needs the module to - which the ClsInst belongs. We can get this from is_dfun_name. - -* In is_tcs, - Nothing means that this type arg is a type variable - - (Just n) means that this type arg is a - TyConApp with a type constructor of n. - This is always a real tycon, never a synonym! - (Two different synonyms might match, but two - different real tycons can't.) - NB: newtypes are not transparent, though! --} - -{- -Note [Template tyvars are fresh] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_tvs field of a ClsInst has *completely fresh* tyvars. -That is, they are - * distinct from any other ClsInst - * distinct from any tyvars free in predicates that may - be looked up in the class instance environment -Reason for freshness: we use unification when checking for overlap -etc, and that requires the tyvars to be distinct. - -The invariant is checked by the ASSERT in lookupInstEnv'. - -Note [Proper-match fields] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_tvs, is_cls, is_tys fields are simply cached values, pulled -out (lazily) from the dfun id. They are cached here simply so -that we don't need to decompose the DFunId each time we want -to match it. The hope is that the rough-match fields mean -that we often never poke the proper-match fields. - -However, note that: - * is_tvs must be a superset of the free vars of is_tys - - * is_tvs, is_tys may be alpha-renamed compared to the ones in - the dfun Id - -Note [Haddock assumptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For normal user-written instances, Haddock relies on - - * the SrcSpan of - * the Name of - * the is_dfun of - * an Instance - -being equal to - - * the SrcSpan of - * the instance head type of - * the InstDecl used to construct the Instance. --} - -instanceDFunId :: ClsInst -> DFunId -instanceDFunId = is_dfun - -updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst -updateClsInstDFun tidy_dfun ispec - = ispec { is_dfun = tidy_dfun (is_dfun ispec) } - -instanceRoughTcs :: ClsInst -> [Maybe Name] -instanceRoughTcs = is_tcs - - -instance NamedThing ClsInst where - getName ispec = getName (is_dfun ispec) - -instance Outputable ClsInst where - ppr = pprInstance - -pprInstance :: ClsInst -> SDoc --- Prints the ClsInst as an instance declaration -pprInstance ispec - = hang (pprInstanceHdr ispec) - 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) - , whenPprDebug (ppr (is_dfun ispec)) ]) - --- * pprInstanceHdr is used in VStudio to populate the ClassView tree -pprInstanceHdr :: ClsInst -> SDoc --- Prints the ClsInst as an instance declaration -pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) - = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) - -pprInstances :: [ClsInst] -> SDoc -pprInstances ispecs = vcat (map pprInstance ispecs) - -instanceHead :: ClsInst -> ([TyVar], Class, [Type]) --- Returns the head, using the fresh tyavs from the ClsInst -instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) - = (tvs, cls, tys) - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) - --- | Collects the names of concrete types and type constructors that make --- up the head of a class instance. For instance, given `class Foo a b`: --- --- `instance Foo (Either (Maybe Int) a) Bool` would yield --- [Either, Maybe, Int, Bool] --- --- Used in the implementation of ":info" in GHCi. --- --- The 'tcSplitSigmaTy' is because of --- instance Foo a => Baz T where ... --- The decl is an orphan if Baz and T are both not locally defined, --- even if Foo *is* locally defined -orphNamesOfClsInst :: ClsInst -> NameSet -orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) - = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm - -instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) --- Decomposes the DFunId -instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) - -mkLocalInstance :: DFunId -> OverlapFlag - -> [TyVar] -> Class -> [Type] - -> ClsInst --- Used for local instances, where we can safely pull on the DFunId. --- Consider using newClsInst instead; this will also warn if --- the instance is an orphan. -mkLocalInstance dfun oflag tvs cls tys - = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs - , is_dfun_name = dfun_name - , is_cls = cls, is_cls_nm = cls_name - , is_tys = tys, is_tcs = roughMatchTcs tys - , is_orphan = orph - } - where - cls_name = className cls - dfun_name = idName dfun - this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name - is_local name = nameIsLocalOrFrom this_mod name - - -- Compute orphanhood. See Note [Orphans] in InstEnv - (cls_tvs, fds) = classTvsFds cls - arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] - - -- See Note [When exactly is an instance decl an orphan?] - orph | is_local cls_name = NotOrphan (nameOccName cls_name) - | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns - | otherwise = IsOrphan - - notOrphan NotOrphan{} = True - notOrphan _ = False - - mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name - -- that is not in the "determined" arguments - mb_ns | null fds = [choose_one arg_names] - | otherwise = map do_one fds - do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names - , not (tv `elem` rtvs)] - - choose_one nss = chooseOrphanAnchor (unionNameSets nss) - -mkImportedInstance :: Name -- ^ the name of the class - -> [Maybe Name] -- ^ the types which the class was applied to - -> Name -- ^ the 'Name' of the dictionary binding - -> DFunId -- ^ the 'Id' of the dictionary. - -> OverlapFlag -- ^ may this instance overlap? - -> IsOrphan -- ^ is this instance an orphan? - -> ClsInst --- Used for imported instances, where we get the rough-match stuff --- from the interface file --- The bound tyvars of the dfun are guaranteed fresh, because --- the dfun has been typechecked out of the same interface file -mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan - = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs, is_tys = tys - , is_dfun_name = dfun_name - , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs - , is_orphan = orphan } - where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) - -{- -Note [When exactly is an instance decl an orphan?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (see GHC.Iface.Utils.instanceToIfaceInst, which implements this) -Roughly speaking, an instance is an orphan if its head (after the =>) -mentions nothing defined in this module. - -Functional dependencies complicate the situation though. Consider - - module M where { class C a b | a -> b } - -and suppose we are compiling module X: - - module X where - import M - data T = ... - instance C Int T where ... - -This instance is an orphan, because when compiling a third module Y we -might get a constraint (C Int v), and we'd want to improve v to T. So -we must make sure X's instances are loaded, even if we do not directly -use anything from X. - -More precisely, an instance is an orphan iff - - If there are no fundeps, then at least of the names in - the instance head is locally defined. - - If there are fundeps, then for every fundep, at least one of the - names free in a *non-determined* part of the instance head is - defined in this module. - -(Note that these conditions hold trivially if the class is locally -defined.) - - -************************************************************************ -* * - InstEnv, ClsInstEnv -* * -************************************************************************ - -A @ClsInstEnv@ all the instances of that class. The @Id@ inside a -ClsInstEnv mapping is the dfun for that instance. - -If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then - - forall a b, C t1 t2 t3 can be constructed by dfun - -or, to put it another way, we have - - instance (...) => C t1 t2 t3, witnessed by dfun --} - ---------------------------------------------------- -{- -Note [InstEnv determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We turn InstEnvs into a list in some places that don't directly affect -the ABI. That happens when we create output for `:info`. -Unfortunately that nondeterminism is nonlocal and it's hard to tell what it -affects without following a chain of functions. It's also easy to accidentally -make that nondeterminism affect the ABI. Furthermore the envs should be -relatively small, so it should be free to use deterministic maps here. -Testing with nofib and validate detected no difference between UniqFM and -UniqDFM. See also Note [Deterministic UniqFM] --} - -type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class - -- See Note [InstEnv determinism] - --- | 'InstEnvs' represents the combination of the global type class instance --- environment, the local type class instance environment, and the set of --- transitively reachable orphan modules (according to what modules have been --- directly imported) used to test orphan instance visibility. -data InstEnvs = InstEnvs { - ie_global :: InstEnv, -- External-package instances - ie_local :: InstEnv, -- Home-package instances - ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively - -- reachable from the module being compiled - -- See Note [Instance lookup and orphan instances] - } - --- | Set of visible orphan modules, according to what modules have been directly --- imported. This is based off of the dep_orphs field, which records --- transitively reachable orphan modules (modules that define orphan instances). -type VisibleOrphanModules = ModuleSet - -newtype ClsInstEnv - = ClsIE [ClsInst] -- The instances for a particular class, in any order - -instance Outputable ClsInstEnv where - ppr (ClsIE is) = pprInstances is - --- INVARIANTS: --- * The is_tvs are distinct in each ClsInst --- of a ClsInstEnv (so we can safely unify them) - --- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: --- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] --- The "a" in the pattern must be one of the forall'd variables in --- the dfun type. - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUDFM - -instEnvElts :: InstEnv -> [ClsInst] -instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] - -- See Note [InstEnv determinism] - -instEnvClasses :: InstEnv -> [Class] -instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] - --- | Test if an instance is visible, by checking that its origin module --- is in 'VisibleOrphanModules'. --- See Note [Instance lookup and orphan instances] -instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool -instIsVisible vis_mods ispec - -- NB: Instances from the interactive package always are visible. We can't - -- add interactive modules to the set since we keep creating new ones - -- as a GHCi session progresses. - = case nameModule_maybe (is_dfun_name ispec) of - Nothing -> True - Just mod | isInteractiveModule mod -> True - | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods - | otherwise -> True - -classInstances :: InstEnvs -> Class -> [ClsInst] -classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls - = get home_ie ++ get pkg_ie - where - get env = case lookupUDFM env cls of - Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts - Nothing -> [] - --- | Checks for an exact match of ClsInst in the instance environment. --- We use this when we do signature checking in TcRnDriver -memberInstEnv :: InstEnv -> ClsInst -> Bool -memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = - maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) - (lookupUDFM inst_env cls_nm) - where - identicalDFunType cls1 cls2 = - eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) - -extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv -extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs - -extendInstEnv :: InstEnv -> ClsInst -> InstEnv -extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) - where - add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) - -deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv -deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = adjustUDFM adjust inst_env cls_nm - where - adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) - -deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv --- Delete a specific instance fron an InstEnv -deleteDFunFromInstEnv inst_env dfun - = adjustUDFM adjust inst_env cls - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) - adjust (ClsIE items) = ClsIE (filterOut same_dfun items) - same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' - -identicalClsInstHead :: ClsInst -> ClsInst -> Bool --- ^ True when when the instance heads are the same --- e.g. both are Eq [(a,b)] --- Used for overriding in GHCi --- Obviously should be insensitive to alpha-renaming -identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) - (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) - = cls_nm1 == cls_nm2 - && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields - && isJust (tcMatchTys tys1 tys2) - && isJust (tcMatchTys tys2 tys1) - -{- -************************************************************************ -* * - Looking up an instance -* * -************************************************************************ - -@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since -the env is kept ordered, the first match must be the only one. The -thing we are looking up can have an arbitrary "flexi" part. - -Note [Instance lookup and orphan instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are compiling a module M, and we have a zillion packages -loaded, and we are looking up an instance for C (T W). If we find a -match in module 'X' from package 'p', should be "in scope"; that is, - - is p:X in the transitive closure of modules imported from M? - -The difficulty is that the "zillion packages" might include ones loaded -through earlier invocations of the GHC API, or earlier module loads in GHCi. -They might not be in the dependencies of M itself; and if not, the instances -in them should not be visible. #2182, #8427. - -There are two cases: - * If the instance is *not an orphan*, then module X defines C, T, or W. - And in order for those types to be involved in typechecking M, it - must be that X is in the transitive closure of M's imports. So we - can use the instance. - - * If the instance *is an orphan*, the above reasoning does not apply. - So we keep track of the set of orphan modules transitively below M; - this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. - - If module p:X is in this set, then we can use the instance, otherwise - we can't. - -Note [Rules for instance lookup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These functions implement the carefully-written rules in the user -manual section on "overlapping instances". At risk of duplication, -here are the rules. If the rules change, change this text and the -user manual simultaneously. The link may be this: -http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap - -The willingness to be overlapped or incoherent is a property of the -instance declaration itself, controlled as follows: - - * An instance is "incoherent" - if it has an INCOHERENT pragma, or - if it appears in a module compiled with -XIncoherentInstances. - - * An instance is "overlappable" - if it has an OVERLAPPABLE or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or - if the instance is incoherent. - - * An instance is "overlapping" - if it has an OVERLAPPING or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or - if the instance is incoherent. - compiled with -XOverlappingInstances. - -Now suppose that, in some client module, we are searching for an instance -of the target constraint (C ty1 .. tyn). The search works like this. - -* Find all instances `I` that *match* the target constraint; that is, the - target constraint is a substitution instance of `I`. These instance - declarations are the *candidates*. - -* Eliminate any candidate `IX` for which both of the following hold: - - - There is another candidate `IY` that is strictly more specific; that - is, `IY` is a substitution instance of `IX` but not vice versa. - - - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This - "either/or" design, rather than a "both/and" design, allow a - client to deliberately override an instance from a library, - without requiring a change to the library.) - -- If exactly one non-incoherent candidate remains, select it. If all - remaining candidates are incoherent, select an arbitrary one. - Otherwise the search fails (i.e. when more than one surviving - candidate is not incoherent). - -- If the selected candidate (from the previous step) is incoherent, the - search succeeds, returning that candidate. - -- If not, find all instances that *unify* with the target constraint, - but do not *match* it. Such non-candidate instances might match when - the target constraint is further instantiated. If all of them are - incoherent, the search succeeds, returning the selected candidate; if - not, the search fails. - -Notice that these rules are not influenced by flag settings in the -client module, where the instances are *used*. These rules make it -possible for a library author to design a library that relies on -overlapping instances without the client having to know. - -Note [Overlapping instances] (NB: these notes are quite old) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Overlap is permitted, but only in such a way that one can make -a unique choice when looking up. That is, overlap is only permitted if -one template matches the other, or vice versa. So this is ok: - - [a] [Int] - -but this is not - - (Int,a) (b,Int) - -If overlap is permitted, the list is kept most specific first, so that -the first lookup is the right choice. - - -For now we just use association lists. - -\subsection{Avoiding a problem with overlapping} - -Consider this little program: - -\begin{pseudocode} - class C a where c :: a - class C a => D a where d :: a - - instance C Int where c = 17 - instance D Int where d = 13 - - instance C a => C [a] where c = [c] - instance ({- C [a], -} D a) => D [a] where d = c - - instance C [Int] where c = [37] - - main = print (d :: [Int]) -\end{pseudocode} - -What do you think `main' prints (assuming we have overlapping instances, and -all that turned on)? Well, the instance for `D' at type `[a]' is defined to -be `c' at the same type, and we've got an instance of `C' at `[Int]', so the -answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because -the `C [Int]' instance is more specific). - -Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That -was easy ;-) Let's just consult hugs for good measure. Wait - if I use old -hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it -doesn't even compile! What's going on!? - -What hugs complains about is the `D [a]' instance decl. - -\begin{pseudocode} - ERROR "mj.hs" (line 10): Cannot build superclass instance - *** Instance : D [a] - *** Context supplied : D a - *** Required superclass : C [a] -\end{pseudocode} - -You might wonder what hugs is complaining about. It's saying that you -need to add `C [a]' to the context of the `D [a]' instance (as appears -in comments). But there's that `C [a]' instance decl one line above -that says that I can reduce the need for a `C [a]' instance to the -need for a `C a' instance, and in this case, I already have the -necessary `C a' instance (since we have `D a' explicitly in the -context, and `C' is a superclass of `D'). - -Unfortunately, the above reasoning indicates a premature commitment to the -generic `C [a]' instance. I.e., it prematurely rules out the more specific -instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to -add the context that hugs suggests (uncomment the `C [a]'), effectively -deferring the decision about which instance to use. - -Now, interestingly enough, 4.04 has this same bug, but it's covered up -in this case by a little known `optimization' that was disabled in -4.06. Ghc-4.04 silently inserts any missing superclass context into -an instance declaration. In this case, it silently inserts the `C -[a]', and everything happens to work out. - -(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for -`Mark Jones', although Mark claims no credit for the `optimization' in -question, and would rather it stopped being called the `Mark Jones -optimization' ;-) - -So, what's the fix? I think hugs has it right. Here's why. Let's try -something else out with ghc-4.04. Let's add the following line: - - d' :: D a => [a] - d' = c - -Everyone raise their hand who thinks that `d :: [Int]' should give a -different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The -`optimization' only applies to instance decls, not to regular -bindings, giving inconsistent behavior. - -Old hugs had this same bug. Here's how we fixed it: like GHC, the -list of instances for a given class is ordered, so that more specific -instances come before more generic ones. For example, the instance -list for C might contain: - ..., C Int, ..., C a, ... -When we go to look for a `C Int' instance we'll get that one first. -But what if we go looking for a `C b' (`b' is unconstrained)? We'll -pass the `C Int' instance, and keep going. But if `b' is -unconstrained, then we don't know yet if the more specific instance -will eventually apply. GHC keeps going, and matches on the generic `C -a'. The fix is to, at each step, check to see if there's a reverse -match, and if so, abort the search. This prevents hugs from -prematurely choosing a generic instance when a more specific one -exists. - ---Jeff - -BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in -this test. Suppose the instance envt had - ..., forall a b. C a a b, ..., forall a b c. C a b c, ... -(still most specific first) -Now suppose we are looking for (C x y Int), where x and y are unconstrained. - C x y Int doesn't match the template {a,b} C a a b -but neither does - C a a b match the template {x,y} C x y Int -But still x and y might subsequently be unified so they *do* match. - -Simple story: unify, don't match. --} - -type DFunInstType = Maybe Type - -- Just ty => Instantiate with this type - -- Nothing => Instantiate with any type of this tyvar's kind - -- See Note [DFunInstType: instantiating types] - -type InstMatch = (ClsInst, [DFunInstType]) - -type ClsInstLookupResult - = ( [InstMatch] -- Successful matches - , [ClsInst] -- These don't match but do unify - , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell - -- (see Note [Safe Haskell Overlapping Instances] in - -- TcSimplify). - -{- -Note [DFunInstType: instantiating types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A successful match is a ClsInst, together with the types at which - the dfun_id in the ClsInst should be instantiated -The instantiating types are (Either TyVar Type)s because the dfun -might have some tyvars that *only* appear in arguments - dfun :: forall a b. C a b, Ord b => D [a] -When we match this against D [ty], we return the instantiating types - [Just ty, Nothing] -where the 'Nothing' indicates that 'b' can be freely instantiated. -(The caller instantiates it to a flexi type variable, which will - presumably later become fixed via functional dependencies.) --} - --- |Look up an instance in the given instance environment. The given class application must match exactly --- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, --- yield 'Left errorMessage'. -lookupUniqueInstEnv :: InstEnvs - -> Class -> [Type] - -> Either MsgDoc (ClsInst, [Type]) -lookupUniqueInstEnv instEnv cls tys - = case lookupInstEnv False instEnv cls tys of - ([(inst, inst_tys)], _, _) - | noFlexiVar -> Right (inst, inst_tys') - | otherwise -> Left $ text "flexible type variable:" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) - where - inst_tys' = [ty | Just ty <- inst_tys] - noFlexiVar = all isJust inst_tys - _other -> Left $ text "instance not found" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) - -lookupInstEnv' :: InstEnv -- InstEnv to look in - -> VisibleOrphanModules -- But filter against this - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [ClsInst]) -- These don't match but do unify - -- (no incoherent ones in here) --- The second component of the result pair happens when we look up --- Foo [a] --- in an InstEnv that has entries for --- Foo [Int] --- Foo [b] --- Then which we choose would depend on the way in which 'a' --- is instantiated. So we report that Foo [b] is a match (mapping b->a) --- but Foo [Int] is a unifier. This gives the caller a better chance of --- giving a suitable error message - -lookupInstEnv' ie vis_mods cls tys - = lookup ie - where - rough_tcs = roughMatchTcs tys - all_tvs = all isNothing rough_tcs - - -------------- - lookup env = case lookupUDFM env cls of - Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts) -> find [] [] insts - - -------------- - find ms us [] = (ms, us) - find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) - | not (instIsVisible vis_mods item) - = find ms us rest -- See Note [Instance lookup and orphan instances] - - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find ms us rest - - | Just subst <- tcMatchTys tpl_tys tys - = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest - - -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] - -- Ignore ones that are incoherent: Note [Incoherent instances] - | isIncoherent item - = find ms us rest - - | otherwise - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, - (ppr cls <+> ppr tys <+> ppr all_tvs) $$ - (ppr tpl_tvs <+> ppr tpl_tys) - ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - -- See Note [Template tyvars are fresh] - case tcUnifyTys instanceBindFun tpl_tys tys of - Just _ -> find ms (item:us) rest - Nothing -> find ms us rest - where - tpl_tv_set = mkVarSet tpl_tvs - ---------------- --- This is the common way to call this function. -lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions - -> InstEnvs -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ClsInstLookupResult --- ^ See Note [Rules for instance lookup] --- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify --- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -lookupInstEnv check_overlap_safe - (InstEnvs { ie_global = pkg_ie - , ie_local = home_ie - , ie_visible = vis_mods }) - cls - tys - = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ - (final_matches, final_unifs, unsafe_overlapped) - where - (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys - (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys - all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs - final_matches = foldr insert_overlapping [] all_matches - -- Even if the unifs is non-empty (an error situation) - -- we still prune the matches, so that the error message isn't - -- misleading (complaining of multiple matches when some should be - -- overlapped away) - - unsafe_overlapped - = case final_matches of - [match] -> check_safe match - _ -> [] - - -- If the selected match is incoherent, discard all unifiers - final_unifs = case final_matches of - (m:_) | isIncoherent (fst m) -> [] - _ -> all_unifs - - -- NOTE [Safe Haskell isSafeOverlap] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- We restrict code compiled in 'Safe' mode from overriding code - -- compiled in any other mode. The rationale is that code compiled - -- in 'Safe' mode is code that is untrusted by the ghc user. So - -- we shouldn't let that code change the behaviour of code the - -- user didn't compile in 'Safe' mode since that's the code they - -- trust. So 'Safe' instances can only overlap instances from the - -- same module. A same instance origin policy for safe compiled - -- instances. - check_safe (inst,_) - = case check_overlap_safe && unsafeTopInstance inst of - -- make sure it only overlaps instances from the same module - True -> go [] all_matches - -- most specific is from a trusted location. - False -> [] - where - go bad [] = bad - go bad (i@(x,_):unchecked) = - if inSameMod x || isOverlappable x - then go bad unchecked - else go (i:bad) unchecked - - inSameMod b = - let na = getName $ getName inst - la = isInternalName na - nb = getName $ getName b - lb = isInternalName nb - in (la && lb) || (nameModule na == nameModule nb) - - -- We consider the most specific instance unsafe when it both: - -- (1) Comes from a module compiled as `Safe` - -- (2) Is an orphan instance, OR, an instance for a MPTC - unsafeTopInstance inst = isSafeOverlap (is_flag inst) && - (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) - ---------------- -insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] --- ^ Add a new solution, knocking out strictly less specific ones --- See Note [Rules for instance lookup] -insert_overlapping new_item [] = [new_item] -insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) - | new_beats_old -- New strictly overrides old - , not old_beats_new - , new_inst `can_override` old_inst - = insert_overlapping new_item old_items - - | old_beats_new -- Old strictly overrides new - , not new_beats_old - , old_inst `can_override` new_inst - = old_item : old_items - - -- Discard incoherent instances; see Note [Incoherent instances] - | isIncoherent old_inst -- Old is incoherent; discard it - = insert_overlapping new_item old_items - | isIncoherent new_inst -- New is incoherent; discard it - = old_item : old_items - - -- Equal or incomparable, and neither is incoherent; keep both - | otherwise - = old_item : insert_overlapping new_item old_items - where - - new_beats_old = new_inst `more_specific_than` old_inst - old_beats_new = old_inst `more_specific_than` new_inst - - -- `instB` can be instantiated to match `instA` - -- or the two are equal - instA `more_specific_than` instB - = isJust (tcMatchTys (is_tys instB) (is_tys instA)) - - instA `can_override` instB - = isOverlapping instA || isOverlappable instB - -- Overlap permitted if either the more specific instance - -- is marked as overlapping, or the more general one is - -- marked as overlappable. - -- Latest change described in: #9242. - -- Previous change: #3877, Dec 10. - -{- -Note [Incoherent instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For some classes, the choice of a particular instance does not matter, any one -is good. E.g. consider - - class D a b where { opD :: a -> b -> String } - instance D Int b where ... - instance D a Int where ... - - g (x::Int) = opD x x -- Wanted: D Int Int - -For such classes this should work (without having to add an "instance D Int -Int", and using -XOverlappingInstances, which would then work). This is what --XIncoherentInstances is for: Telling GHC "I don't care which instance you use; -if you can use one, use it." - -Should this logic only work when *all* candidates have the incoherent flag, or -even when all but one have it? The right choice is the latter, which can be -justified by comparing the behaviour with how -XIncoherentInstances worked when -it was only about the unify-check (note [Overlapping instances]): - -Example: - class C a b c where foo :: (a,b,c) - instance C [a] b Int - instance [incoherent] [Int] b c - instance [incoherent] C a Int c -Thanks to the incoherent flags, - [Wanted] C [a] b Int -works: Only instance one matches, the others just unify, but are marked -incoherent. - -So I can write - (foo :: ([a],b,Int)) :: ([Int], Int, Int). -but if that works then I really want to be able to write - foo :: ([Int], Int, Int) -as well. Now all three instances from above match. None is more specific than -another, so none is ruled out by the normal overlapping rules. One of them is -not incoherent, but we still want this to compile. Hence the -"all-but-one-logic". - -The implementation is in insert_overlapping, where we remove matching -incoherent instances as long as there are others. - - - -************************************************************************ -* * - Binding decisions -* * -************************************************************************ --} - -instanceBindFun :: TyCoVar -> BindFlag -instanceBindFun tv | isOverlappableTyVar tv = Skolem - | otherwise = BindMe - -- Note [Binding when looking up instances] - -{- -Note [Binding when looking up instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When looking up in the instance environment, or family-instance environment, -we are careful about multiple matches, as described above in -Note [Overlapping instances] - -The key_tys can contain skolem constants, and we can guarantee that those -are never going to be instantiated to anything, so we should not involve -them in the unification test. Example: - class Foo a where { op :: a -> Int } - instance Foo a => Foo [a] -- NB overlap - instance Foo [Int] -- NB overlap - data T = forall a. Foo a => MkT a - f :: T -> Int - f (MkT x) = op [x,x] -The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd -complain, saying that the choice of instance depended on the instantiation -of 'a'; but of course it isn't *going* to be instantiated. - -We do this only for isOverlappableTyVar skolems. For example we reject - g :: forall a => [a] -> Int - g x = op x -on the grounds that the correct instance depends on the instantiation of 'a' --} diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs deleted file mode 100644 --- a/compiler/types/OptCoercion.hs +++ /dev/null @@ -1,1206 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP #-} - -module OptCoercion ( optCoercion, checkAxInstCo ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import TyCoRep -import TyCoSubst -import Coercion -import Type hiding( substTyVarBndr, substTy ) -import TcType ( exactTyCoVarsOfType ) -import TyCon -import CoAxiom -import VarSet -import VarEnv -import Outputable -import FamInstEnv ( flattenTys ) -import Pair -import ListSetOps ( getNth ) -import Util -import Unify -import InstEnv -import Control.Monad ( zipWithM ) - -{- -%************************************************************************ -%* * - Optimising coercions -%* * -%************************************************************************ - -Note [Optimising coercion optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Looking up a coercion's role or kind is linear in the size of the -coercion. Thus, doing this repeatedly during the recursive descent -of coercion optimisation is disastrous. We must be careful to avoid -doing this if at all possible. - -Because it is generally easy to know a coercion's components' roles -from the role of the outer coercion, we pass down the known role of -the input in the algorithm below. We also keep functions opt_co2 -and opt_co3 separate from opt_co4, so that the former two do Phantom -checks that opt_co4 can avoid. This is a big win because Phantom coercions -rarely appear within non-phantom coercions -- only in some TyConAppCos -and some AxiomInstCos. We handle these cases specially by calling -opt_co2. - -Note [Optimising InstCo] -~~~~~~~~~~~~~~~~~~~~~~~~ -(1) tv is a type variable -When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. - -Let's look at the typing rules. - -h : k1 ~ k2 -tv:k1 |- g : t1 ~ t2 ------------------------------ -ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) - -g1 : (all tv:k1.t1') ~ (all tv:k2.t2') -g2 : s1 ~ s2 --------------------- -InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] - -We thus want some coercion proving this: - - (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) - -If we substitute the *type* tv for the *coercion* -(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. -This is bizarre, -though, because we're substituting a type variable with a coercion. However, -this operation already exists: it's called *lifting*, and defined in Coercion. -We just need to enhance the lifting operation to be able to deal with -an ambient substitution, which is why a LiftingContext stores a TCvSubst. - -(2) cv is a coercion variable -Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. - -h : (t1 ~r t2) ~N (t3 ~r t4) -cv : t1 ~r t2 |- g : t1' ~r2 t2' -n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 -n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 ------------------------------------------------- -ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 - (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) - -g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') -g2 : h1 ~N h2 -h1 : t1 ~r t2 -h2 : t3 ~r t4 ------------------------------------------------- -InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] - -We thus want some coercion proving this: - - t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] - -So we substitute the coercion variable c for the coercion -(h1 ~N (n1; h2; sym n2)) in g. --} - -optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo --- ^ optCoercion applies a substitution to a coercion, --- *and* optimises it to reduce its size -optCoercion dflags env co - | hasNoOptCoercion dflags = substCo env co - | otherwise = optCoercion' env co - -optCoercion' :: TCvSubst -> Coercion -> NormalCo -optCoercion' env co - | debugIsOn - = let out_co = opt_co1 lc False co - (Pair in_ty1 in_ty2, in_role) = coercionKindRole co - (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co - in - ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && - substTyUnchecked env in_ty2 `eqType` out_ty2 && - in_role == out_role - , text "optCoercion changed types!" - $$ hang (text "in_co:") 2 (ppr co) - $$ hang (text "in_ty1:") 2 (ppr in_ty1) - $$ hang (text "in_ty2:") 2 (ppr in_ty2) - $$ hang (text "out_co:") 2 (ppr out_co) - $$ hang (text "out_ty1:") 2 (ppr out_ty1) - $$ hang (text "out_ty2:") 2 (ppr out_ty2) - $$ hang (text "subst:") 2 (ppr env) ) - out_co - - | otherwise = opt_co1 lc False co - where - lc = mkSubstLiftingContext env - -type NormalCo = Coercion - -- Invariants: - -- * The substitution has been fully applied - -- * For trans coercions (co1 `trans` co2) - -- co1 is not a trans, and neither co1 nor co2 is identity - -type NormalNonIdCo = NormalCo -- Extra invariant: not the identity - --- | Do we apply a @sym@ to the result? -type SymFlag = Bool - --- | Do we force the result to be representational? -type ReprFlag = Bool - --- | Optimize a coercion, making no assumptions. All coercions in --- the lifting context are already optimized (and sym'd if nec'y) -opt_co1 :: LiftingContext - -> SymFlag - -> Coercion -> NormalCo -opt_co1 env sym co = opt_co2 env sym (coercionRole co) co - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's role. No other assumptions. -opt_co2 :: LiftingContext - -> SymFlag - -> Role -- ^ The role of the input coercion - -> Coercion -> NormalCo -opt_co2 env sym Phantom co = opt_phantom env sym co -opt_co2 env sym r co = opt_co3 env sym Nothing r co - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo -opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co -opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co - -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore -opt_co3 env sym _ r co = opt_co4_wrap env sym False r co - --- See Note [Optimising coercion optimisation] --- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo - -opt_co4_wrap = opt_co4 -{- -opt_co4_wrap env sym rep r co - = pprTrace "opt_co4_wrap {" - ( vcat [ text "Sym:" <+> ppr sym - , text "Rep:" <+> ppr rep - , text "Role:" <+> ppr r - , text "Co:" <+> ppr co ]) $ - ASSERT( r == coercionRole co ) - let result = opt_co4 env sym rep r co in - pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ - result --} - -opt_co4 env _ rep r (Refl ty) - = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr Nominal $$ - text "Type:" <+> ppr ty ) - liftCoSubst (chooseRole rep r) env ty - -opt_co4 env _ rep r (GRefl _r ty MRefl) - = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr _r $$ - text "Type:" <+> ppr ty ) - liftCoSubst (chooseRole rep r) env ty - -opt_co4 env sym rep r (GRefl _r ty (MCo co)) - = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr _r $$ - text "Type:" <+> ppr ty ) - if isGReflCo co || isGReflCo co' - then liftCoSubst r' env ty - else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) - where - r' = chooseRole rep r - ty' = substTy (lcSubstLeft env) ty - co' = opt_co4 env False False Nominal co - -opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co - -- surprisingly, we don't have to do anything to the env here. This is - -- because any "lifting" substitutions in the env are tied to ForAllCos, - -- which treat their left and right sides differently. We don't want to - -- exchange them. - -opt_co4 env sym rep r g@(TyConAppCo _r tc cos) - = ASSERT( r == _r ) - case (rep, r) of - (True, Nominal) -> - mkTyConAppCo Representational tc - (zipWith3 (opt_co3 env sym) - (map Just (tyConRolesRepresentational tc)) - (repeat Nominal) - cos) - (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) - (_, Representational) -> - -- must use opt_co2 here, because some roles may be P - -- See Note [Optimising coercion optimisation] - mkTyConAppCo r tc (zipWith (opt_co2 env sym) - (tyConRolesRepresentational tc) -- the current roles - cos) - (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) - -opt_co4 env sym rep r (AppCo co1 co2) - = mkAppCo (opt_co4_wrap env sym rep r co1) - (opt_co4_wrap env sym False Nominal co2) - -opt_co4 env sym rep r (ForAllCo tv k_co co) - = case optForAllCoBndr env sym tv k_co of - (env', tv', k_co') -> mkForAllCo tv' k_co' $ - opt_co4_wrap env' sym rep r co - -- Use the "mk" functions to check for nested Refls - -opt_co4 env sym rep r (FunCo _r co1 co2) - = ASSERT( r == _r ) - if rep - then mkFunCo Representational co1' co2' - else mkFunCo r co1' co2' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - -opt_co4 env sym rep r (CoVarCo cv) - | Just co <- lookupCoVar (lcTCvSubst env) cv - = opt_co4_wrap (zapLiftingContext env) sym rep r co - - | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] - = mkReflCo (chooseRole rep r) ty1 - - | otherwise - = ASSERT( isCoVar cv1 ) - wrapRole rep r $ wrapSym sym $ - CoVarCo cv1 - - where - Pair ty1 ty2 = coVarTypes cv1 - - cv1 = case lookupInScope (lcInScopeSet env) cv of - Just cv1 -> cv1 - Nothing -> WARN( True, text "opt_co: not in scope:" - <+> ppr cv $$ ppr env) - cv - -- cv1 might have a substituted kind! - -opt_co4 _ _ _ _ (HoleCo h) - = pprPanic "opt_univ fell into a hole" (ppr h) - -opt_co4 env sym rep r (AxiomInstCo con ind cos) - -- Do *not* push sym inside top-level axioms - -- e.g. if g is a top-level axiom - -- g a : f a ~ a - -- then (sym (g ty)) /= g (sym ty) !! - = ASSERT( r == coAxiomRole con ) - wrapRole rep (coAxiomRole con) $ - wrapSym sym $ - -- some sub-cos might be P: use opt_co2 - -- See Note [Optimising coercion optimisation] - AxiomInstCo con ind (zipWith (opt_co2 env False) - (coAxBranchRoles (coAxiomNthBranch con ind)) - cos) - -- Note that the_co does *not* have sym pushed into it - -opt_co4 env sym rep r (UnivCo prov _r t1 t2) - = ASSERT( r == _r ) - opt_univ env sym prov (chooseRole rep r) t1 t2 - -opt_co4 env sym rep r (TransCo co1 co2) - -- sym (g `o` h) = sym h `o` sym g - | sym = opt_trans in_scope co2' co1' - | otherwise = opt_trans in_scope co1' co2' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - in_scope = lcInScopeSet env - -opt_co4 env _sym rep r (NthCo _r n co) - | Just (ty, _) <- isReflCo_maybe co - , Just (_tc, args) <- ASSERT( r == _r ) - splitTyConApp_maybe ty - = liftCoSubst (chooseRole rep r) env (args `getNth` n) - | Just (ty, _) <- isReflCo_maybe co - , n == 0 - , Just (tv, _) <- splitForAllTy_maybe ty - -- works for both tyvar and covar - = liftCoSubst (chooseRole rep r) env (varType tv) - -opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) - = ASSERT( r == r1 ) - opt_co4_wrap env sym rep r (cos `getNth` n) - -opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) - -- works for both tyvar and covar - = ASSERT( r == _r ) - ASSERT( n == 0 ) - opt_co4_wrap env sym rep Nominal eta - -opt_co4 env sym rep r (NthCo _r n co) - | TyConAppCo _ _ cos <- co' - , let nth_co = cos `getNth` n - = if rep && (r == Nominal) - -- keep propagating the SubCo - then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co - else nth_co - - | ForAllCo _ eta _ <- co' - = if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal eta - else eta - - | otherwise - = wrapRole rep r $ NthCo r n co' - where - co' = opt_co1 env sym co - -opt_co4 env sym rep r (LRCo lr co) - | Just pr_co <- splitAppCo_maybe co - = ASSERT( r == Nominal ) - opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) - | Just pr_co <- splitAppCo_maybe co' - = ASSERT( r == Nominal ) - if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) - else pick_lr lr pr_co - | otherwise - = wrapRole rep Nominal $ LRCo lr co' - where - co' = opt_co4_wrap env sym False Nominal co - - pick_lr CLeft (l, _) = l - pick_lr CRight (_, r) = r - --- See Note [Optimising InstCo] -opt_co4 env sym rep r (InstCo co1 arg) - -- forall over type... - | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 - = opt_co4_wrap (extendLiftingContext env tv - (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) - -- mkSymCo kind_co :: k1 ~ k2 - -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) - -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) - sym rep r co_body - - -- forall over coercion... - | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 - , CoercionTy h1 <- t1 - , CoercionTy h2 <- t2 - = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 - in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body - - -- See if it is a forall after optimization - -- If so, do an inefficient one-variable substitution, then re-optimize - - -- forall over type... - | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' - = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' - (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) - False False r' co_body' - - -- forall over coercion... - | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' - , CoercionTy h1' <- t1' - , CoercionTy h2' <- t2' - = let new_co = mk_new_co cv' kind_co' h1' h2' - in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) - False False r' co_body' - - | otherwise = InstCo co1' arg' - where - co1' = opt_co4_wrap env sym rep r co1 - r' = chooseRole rep r - arg' = opt_co4_wrap env sym False Nominal arg - sym_arg = wrapSym sym arg' - - -- Performance note: don't be alarmed by the two calls to coercionKind - -- here, as only one call to coercionKind is actually demanded per guard. - -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used - -- when checking if co1' (i.e., co1 post-optimization) is a forall. - -- - -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' - -- might have an extra Sym at the front (after being optimized) that co1 - -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) - Pair t1 t2 = coercionKind sym_arg - Pair t1' t2' = coercionKind arg' - - mk_new_co cv kind_co h1 h2 - = let -- h1 :: (t1 ~ t2) - -- h2 :: (t3 ~ t4) - -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) - -- n1 :: t1 ~ t3 - -- n2 :: t2 ~ t4 - -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) - r2 = coVarRole cv - kind_co' = downgradeRole r2 Nominal kind_co - n1 = mkNthCo r2 2 kind_co' - n2 = mkNthCo r2 3 kind_co' - in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 - (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) - -opt_co4 env sym _rep r (KindCo co) - = ASSERT( r == Nominal ) - let kco' = promoteCoercion co in - case kco' of - KindCo co' -> promoteCoercion (opt_co1 env sym co') - _ -> opt_co4_wrap env sym False Nominal kco' - -- This might be able to be optimized more to do the promotion - -- and substitution/optimization at the same time - -opt_co4 env sym _ r (SubCo co) - = ASSERT( r == Representational ) - opt_co4_wrap env sym True Nominal co - --- This could perhaps be optimized more. -opt_co4 env sym rep r (AxiomRuleCo co cs) - = ASSERT( r == coaxrRole co ) - wrapRole rep r $ - wrapSym sym $ - AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) - -{- Note [Optimise CoVarCo to Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have (c :: t~t) we can optimise it to Refl. That increases the -chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) - -We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] -in Coercion. --} - -------------- --- | Optimize a phantom coercion. The input coercion may not necessarily --- be a phantom, but the output sure will be. -opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo -opt_phantom env sym co - = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 - where - Pair ty1 ty2 = coercionKind co - -{- Note [Differing kinds] - ~~~~~~~~~~~~~~~~~~~~~~ -The two types may not have the same kind (although that would be very unusual). -But even if they have the same kind, and the same type constructor, the number -of arguments in a `CoTyConApp` can differ. Consider - - Any :: forall k. k - - Any * Int :: * - Any (*->*) Maybe Int :: * - -Hence the need to compare argument lengths; see #13658 - -} - -opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role - -> Type -> Type -> Coercion -opt_univ env sym (PhantomProv h) _r ty1 ty2 - | sym = mkPhantomCo h' ty2' ty1' - | otherwise = mkPhantomCo h' ty1' ty2' - where - h' = opt_co4 env sym False Nominal h - ty1' = substTy (lcSubstLeft env) ty1 - ty2' = substTy (lcSubstRight env) ty2 - -opt_univ env sym prov role oty1 oty2 - | Just (tc1, tys1) <- splitTyConApp_maybe oty1 - , Just (tc2, tys2) <- splitTyConApp_maybe oty2 - , tc1 == tc2 - , equalLength tys1 tys2 -- see Note [Differing kinds] - -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); - -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps - = let roles = tyConRolesX role tc1 - arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 - arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos - in - mkTyConAppCo role tc1 arg_cos' - - -- can't optimize the AppTy case because we can't build the kind coercions. - - | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 - , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 - -- NB: prov isn't interesting here either - = let k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - eta = mkUnivCo prov' Nominal k1 k2 - -- eta gets opt'ed soon, but not yet. - ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 - - (env', tv1', eta') = optForAllCoBndr env sym tv1 eta - in - mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') - - | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 - , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 - -- NB: prov isn't interesting here either - = let k1 = varType cv1 - k2 = varType cv2 - r' = coVarRole cv1 - eta = mkUnivCo prov' Nominal k1 k2 - eta_d = downgradeRole r' Nominal eta - -- eta gets opt'ed soon, but not yet. - n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` - (mkCoVarCo cv1) `mkTransCo` - (mkNthCo r' 3 eta_d) - ty2' = substTyWithCoVars [cv2] [n_co] ty2 - - (env', cv1', eta') = optForAllCoBndr env sym cv1 eta - in - mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') - - | otherwise - = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 - ty2 = substTyUnchecked (lcSubstRight env) oty2 - (a, b) | sym = (ty2, ty1) - | otherwise = (ty1, ty2) - in - mkUnivCo prov' role a b - - where - prov' = case prov of - PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco - ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco - PluginProv _ -> prov - -------------- -opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList is = zipWith (opt_trans is) - -opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo -opt_trans is co1 co2 - | isReflCo co1 = co2 - -- optimize when co1 is a Refl Co - | otherwise = opt_trans1 is co1 co2 - -opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo --- First arg is not the identity -opt_trans1 is co1 co2 - | isReflCo co2 = co1 - -- optimize when co2 is a Refl Co - | otherwise = opt_trans2 is co1 co2 - -opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo --- Neither arg is the identity -opt_trans2 is (TransCo co1a co1b) co2 - -- Don't know whether the sub-coercions are the identity - = opt_trans is co1a (opt_trans is co1b co2) - -opt_trans2 is co1 co2 - | Just co <- opt_trans_rule is co1 co2 - = co - -opt_trans2 is co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule is co1 co2a - = if isReflCo co1_2a - then co2b - else opt_trans1 is co1_2a co2b - -opt_trans2 _ co1 co2 - = mkTransCo co1 co2 - ------- --- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo - -opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) - = ASSERT( r1 == r2 ) - fireTransRule "GRefl" in_co1 in_co2 $ - mkGReflRightCo r1 t1 (opt_trans is co1 co2) - --- Push transitivity through matching destructors -opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) - | d1 == d2 - , coercionRole co1 == coercionRole co2 - , co1 `compatible_co` co2 - = ASSERT( r1 == r2 ) - fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo r1 d1 (opt_trans is co1 co2) - -opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) - | d1 == d2 - , co1 `compatible_co` co2 - = fireTransRule "PushLR" in_co1 in_co2 $ - mkLRCo d1 (opt_trans is co1 co2) - --- Push transitivity inside instantiation -opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) - | ty1 `eqCoercion` ty2 - , co1 `compatible_co` co2 - = fireTransRule "TrPushInst" in_co1 in_co2 $ - mkInstCo (opt_trans is co1 co2) ty1 - -opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) - in_co2@(UnivCo p2 r2 _tyl2 tyr2) - | Just prov' <- opt_trans_prov p1 p2 - = ASSERT( r1 == r2 ) - fireTransRule "UnivCo" in_co1 in_co2 $ - mkUnivCo prov' r1 tyl1 tyr2 - where - -- if the provenances are different, opt'ing will be very confusing - opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) - = Just $ PhantomProv $ opt_trans is kco1 kco2 - opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) - = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 - opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 - opt_trans_prov _ _ = Nothing - --- Push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) - | tc1 == tc2 - = ASSERT( r1 == r2 ) - fireTransRule "PushTyConApp" in_co1 in_co2 $ - mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) - -opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) - = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case - fireTransRule "PushFun" in_co1 in_co2 $ - mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) - -opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) - -- Must call opt_trans_rule_app; see Note [EtaAppCo] - = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] - --- Eta rules -opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 - | Just cos2 <- etaTyConAppCo_maybe tc co2 - = ASSERT( cos1 `equalLength` cos2 ) - fireTransRule "EtaCompL" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) - | Just cos1 <- etaTyConAppCo_maybe tc co1 - = ASSERT( cos1 `equalLength` cos2 ) - fireTransRule "EtaCompR" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1@(AppCo co1a co1b) co2 - | Just (co2a,co2b) <- etaAppCo_maybe co2 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] - -opt_trans_rule is co1 co2@(AppCo co2a co2b) - | Just (co1a,co1b) <- etaAppCo_maybe co1 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] - --- Push transitivity inside forall --- forall over types. -opt_trans_rule is co1 co2 - | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 - , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 - , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - where - push_trans tv1 eta1 r1 tv2 eta2 r2 - -- Given: - -- co1 = /\ tv1 : eta1. r1 - -- co2 = /\ tv2 : eta2. r2 - -- Wanted: - -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) - = fireTransRule "EtaAllTy_ty" co1 co2 $ - mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') - where - is' = is `extendInScopeSet` tv1 - r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 - --- Push transitivity inside forall --- forall over coercions. -opt_trans_rule is co1 co2 - | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 - , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 - = push_trans cv1 eta1 r1 cv2 eta2 r2 - - | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 - , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 - = push_trans cv1 eta1 r1 cv2 eta2 r2 - - where - push_trans cv1 eta1 r1 cv2 eta2 r2 - -- Given: - -- co1 = /\ cv1 : eta1. r1 - -- co2 = /\ cv2 : eta2. r2 - -- Wanted: - -- n1 = nth 2 eta1 - -- n2 = nth 3 eta1 - -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) - = fireTransRule "EtaAllTy_co" co1 co2 $ - mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') - where - is' = is `extendInScopeSet` cv1 - role = coVarRole cv1 - eta1' = downgradeRole role Nominal eta1 - n1 = mkNthCo role 2 eta1' - n2 = mkNthCo role 3 eta1' - r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` - (mkCoVarCo cv1) `mkTransCo` n2]) - r2 - --- Push transitivity inside axioms -opt_trans_rule is co1 co2 - - -- See Note [Why call checkAxInstCo during optimisation] - -- TrPushSymAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , True <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst - - -- TrPushAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , False <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxR" co1 co2 newAxInst - - -- TrPushSymAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , True <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst - - -- TrPushAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , False <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxL" co1 co2 newAxInst - - -- TrPushAxSym/TrPushSymAx - | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe - , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe - , con1 == con2 - , ind1 == ind2 - , sym1 == not sym2 - , let branch = coAxiomNthBranch con1 ind1 - qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch - lhs = coAxNthLHS con1 ind1 - rhs = coAxBranchRHS branch - pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) - , all (`elemVarSet` pivot_tvs) qtvs - = fireTransRule "TrPushAxSym" co1 co2 $ - if sym2 - -- TrPushAxSym - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs - -- TrPushSymAx - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs - where - co1_is_axiom_maybe = isAxiom_maybe co1 - co2_is_axiom_maybe = isAxiom_maybe co2 - role = coercionRole co1 -- should be the same as coercionRole co2! - -opt_trans_rule _ co1 co2 -- Identity rule - | let ty1 = coercionLKind co1 - r = coercionRole co1 - ty2 = coercionRKind co2 - , ty1 `eqType` ty2 - = fireTransRule "RedTypeDirRefl" co1 co2 $ - mkReflCo r ty2 - -opt_trans_rule _ _ _ = Nothing - --- See Note [EtaAppCo] -opt_trans_rule_app :: InScopeSet - -> Coercion -- original left-hand coercion (printing only) - -> Coercion -- original right-hand coercion (printing only) - -> Coercion -- left-hand coercion "function" - -> [Coercion] -- left-hand coercion "args" - -> Coercion -- right-hand coercion "function" - -> [Coercion] -- right-hand coercion "args" - -> Maybe Coercion -opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs - | AppCo co1aa co1ab <- co1a - , Just (co2aa, co2ab) <- etaAppCo_maybe co2a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) - - | AppCo co2aa co2ab <- co2a - , Just (co1aa, co1ab) <- etaAppCo_maybe co1a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) - - | otherwise - = ASSERT( co1bs `equalLength` co2bs ) - fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ - let rt1a = coercionRKind co1a - - lt2a = coercionLKind co2a - rt2a = coercionRole co2a - - rt1bs = map coercionRKind co1bs - lt2bs = map coercionLKind co2bs - rt2bs = map coercionRole co2bs - - kcoa = mkKindCo $ buildCoercion lt2a rt1a - kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs - - co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a - co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs - co2bs'' = zipWith mkTransCo co2bs' co2bs - in - mkAppCos (opt_trans is co1a co2a') - (zipWith (opt_trans is) co1bs co2bs'') - -fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion -fireTransRule _rule _co1 _co2 res - = Just res - -{- -Note [Conflict checking with AxiomInstCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following type family and axiom: - -type family Equal (a :: k) (b :: k) :: Bool -type instance where - Equal a a = True - Equal a b = False --- -Equal :: forall k::*. k -> k -> Bool -axEqual :: { forall k::*. forall a::k. Equal k a a ~ True - ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } - -We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ -False) and that all is OK. But, all is not OK: we want to use the first branch -of the axiom in this case, not the second. The problem is that the parameters -of the first branch can unify with the supplied coercions, thus meaning that -the first branch should be taken. See also Note [Apartness] in -types/FamInstEnv.hs. - -Note [Why call checkAxInstCo during optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible that otherwise-good-looking optimisations meet with disaster -in the presence of axioms with multiple equations. Consider - -type family Equal (a :: *) (b :: *) :: Bool where - Equal a a = True - Equal a b = False -type family Id (a :: *) :: * where - Id a = a - -axEq :: { [a::*]. Equal a a ~ True - ; [a::*, b::*]. Equal a b ~ False } -axId :: [a::*]. Id a ~ a - -co1 = Equal (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ Equal Int Bool -co2 = axEq[1] - :: Equal Int Bool ~ False - -We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that -co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what -happens when we push the coercions inside? We get - -co3 = axEq[1] (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ False - -which is bogus! This is because the type system isn't smart enough to know -that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type -families. At the time of writing, I (Richard Eisenberg) couldn't think of -a way of detecting this any more efficient than just building the optimised -coercion and checking. - -Note [EtaAppCo] -~~~~~~~~~~~~~~~ -Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd -like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that -the resultant coercions might not be well kinded. Here is an example (things -labeled with x don't matter in this example): - - k1 :: Type - k2 :: Type - - a :: k1 -> Type - b :: k1 - - h :: k1 ~ k2 - - co1a :: x1 ~ (a |> (h -> ) - co1b :: x2 ~ (b |> h) - - co2a :: a ~ x3 - co2b :: b ~ x4 - -First, convince yourself of the following: - - co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) - co2a co2b :: a b ~ x3 x4 - - (a |> (h -> )) (b |> h) `eqType` a b - -That last fact is due to Note [Non-trivial definitional equality] in TyCoRep, -where we ignore coercions in types as long as two types' kinds are the same. -In our case, we meet this last condition, because - - (a |> (h -> )) (b |> h) :: Type - and - a b :: Type - -So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the -suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the -kinds don't match up. - -The solution here is to twiddle the kinds in the output coercions. First, we -need to find coercions - - ak :: kind(a |> (h -> )) ~ kind(a) - bk :: kind(b |> h) ~ kind(b) - -This can be done with mkKindCo and buildCoercion. The latter assumes two -types are identical modulo casts and builds a coercion between them. - -Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the -output coercions. These are well-kinded. - -Also, note that all of this is done after accumulated any nested AppCo -parameters. This step is to avoid quadratic behavior in calling coercionKind. - -The problem described here was first found in dependent/should_compile/dynamic-paper. - --} - --- | Check to make sure that an AxInstCo is internally consistent. --- Returns the conflicting branch, if it exists --- See Note [Conflict checking with AxiomInstCo] -checkAxInstCo :: Coercion -> Maybe CoAxBranch --- defined here to avoid dependencies in Coercion --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -checkAxInstCo (AxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - incomps = coAxBranchIncomps branch - (tys, cotys) = splitAtList tvs (map coercionLKind cos) - co_args = map stripCoercionTy cotys - subst = zipTvSubst tvs tys `composeTCvSubst` - zipCvSubst cvs co_args - target = Type.substTys subst (coAxBranchLHS branch) - in_scope = mkInScopeSet $ - unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - flattened_target = flattenTys in_scope target in - check_no_conflict flattened_target incomps - where - check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch - check_no_conflict _ [] = Nothing - check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) - -- See Note [Apartness] in FamInstEnv - | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp - = check_no_conflict flat rest - | otherwise - = Just b -checkAxInstCo _ = Nothing - - ------------ -wrapSym :: SymFlag -> Coercion -> Coercion -wrapSym sym co | sym = mkSymCo co - | otherwise = co - --- | Conditionally set a role to be representational -wrapRole :: ReprFlag - -> Role -- ^ current role - -> Coercion -> Coercion -wrapRole False _ = id -wrapRole True current = downgradeRole Representational current - --- | If we require a representational role, return that. Otherwise, --- return the "default" role provided. -chooseRole :: ReprFlag - -> Role -- ^ "default" role - -> Role -chooseRole True _ = Representational -chooseRole _ r = r - ------------ -isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) -isAxiom_maybe (SymCo co) - | Just (sym, con, ind, cos) <- isAxiom_maybe co - = Just (not sym, con, ind, cos) -isAxiom_maybe (AxiomInstCo con ind cos) - = Just (False, con, ind, cos) -isAxiom_maybe _ = Nothing - -matchAxiom :: Bool -- True = match LHS, False = match RHS - -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] -matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - | CoAxBranch { cab_tvs = qtvs - , cab_cvs = [] -- can't infer these, so fail if there are any - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind - , Just subst <- liftCoMatch (mkVarSet qtvs) - (if sym then (mkTyConApp tc lhs) else rhs) - co - , all (`isMappedByLC` subst) qtvs - = zipWithM (liftCoSubstTyVar subst) roles qtvs - - | otherwise - = Nothing - -------------- -compatible_co :: Coercion -> Coercion -> Bool --- Check whether (co1 . co2) will be well-kinded -compatible_co co1 co2 - = x1 `eqType` x2 - where - x1 = coercionRKind co1 - x2 = coercionLKind co2 - -------------- -{- -etaForAllCo -~~~~~~~~~~~~~~~~~ -(1) etaForAllCo_ty_maybe -Suppose we have - - g : all a1:k1.t1 ~ all a2:k2.t2 - -but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: - - g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) - -Call the kind coercion h1 and the body coercion h2. We can see that - - h2 : t1 ~ t2[a2 |-> (a1 |> h1)] - -According to the typing rule for ForAllCo, we get that - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) - -or - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) - -as desired. - -(2) etaForAllCo_co_maybe -Suppose we have - - g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 - -Similarly, we do this - - g' = all c1:h1. h2 - : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] - [c1 |-> eta1;c1;sym eta2] - -Here, - - h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) - eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) - eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) - h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) --} -etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) --- Try to make the coercion be of form (forall tv:kind_co. co) -etaForAllCo_ty_maybe co - | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co - = Just (tv, kind_co, r) - - | Pair ty1 ty2 <- coercionKind co - , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 - , isForAllTy_ty ty2 - , let kind_co = mkNthCo Nominal 0 co - = Just ( tv1, kind_co - , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) - - | otherwise - = Nothing - -etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) --- Try to make the coercion be of form (forall cv:kind_co. co) -etaForAllCo_co_maybe co - | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co - = Just (cv, kind_co, r) - - | Pair ty1 ty2 <- coercionKind co - , Just (cv1, _) <- splitForAllTy_co_maybe ty1 - , isForAllTy_co ty2 - = let kind_co = mkNthCo Nominal 0 co - r = coVarRole cv1 - l_co = mkCoVarCo cv1 - kind_co' = downgradeRole r Nominal kind_co - r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` - l_co `mkTransCo` - (mkNthCo r 3 kind_co') - in Just ( cv1, kind_co - , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) - - | otherwise - = Nothing - -etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) --- If possible, split a coercion --- g :: t1a t1b ~ t2a t2b --- into a pair of coercions (left g, right g) -etaAppCo_maybe co - | Just (co1,co2) <- splitAppCo_maybe co - = Just (co1,co2) - | (Pair ty1 ty2, Nominal) <- coercionKindRole co - , Just (_,t1) <- splitAppTy_maybe ty1 - , Just (_,t2) <- splitAppTy_maybe ty2 - , let isco1 = isCoercionTy t1 - , let isco2 = isCoercionTy t2 - , isco1 == isco2 - = Just (LRCo CLeft co, LRCo CRight co) - | otherwise - = Nothing - -etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] --- If possible, split a coercion --- g :: T s1 .. sn ~ T t1 .. tn --- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] -etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) - = ASSERT( tc == tc2 ) Just cos2 - -etaTyConAppCo_maybe tc co - | not (mustBeSaturated tc) - , (Pair ty1 ty2, r) <- coercionKindRole co - , Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep - , let n = length tys1 - , tys2 `lengthIs` n -- This can fail in an erroneous program - -- E.g. T a ~# T a b - -- #14607 - = ASSERT( tc == tc1 ) - Just (decomposeCo n co (tyConRolesX r tc1)) - -- NB: n might be <> tyConArity tc - -- e.g. data family T a :: * -> * - -- g :: T a b ~ T c d - - | otherwise - = Nothing - -{- -Note [Eta for AppCo] -~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: s1 t1 ~ s2 t2 - -Then we can't necessarily make - left g :: s1 ~ s2 - right g :: t1 ~ t2 -because it's possible that - s1 :: * -> * t1 :: * - s2 :: (*->*) -> * t2 :: * -> * -and in that case (left g) does not have the same -kind on either side. - -It's enough to check that - kind t1 = kind t2 -because if g is well-kinded then - kind (s1 t2) = kind (s2 t2) -and these two imply - kind s1 = kind s2 - --} - -optForAllCoBndr :: LiftingContext -> Bool - -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) -optForAllCoBndr env sym - = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/types/TyCoFVs.hs b/compiler/types/TyCoFVs.hs deleted file mode 100644 --- a/compiler/types/TyCoFVs.hs +++ /dev/null @@ -1,984 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TyCoFVs - ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, - - tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoFVsOfType, tyCoVarsOfTypeList, - tyCoFVsOfTypes, tyCoVarsOfTypesList, - deepTcvFolder, - - shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, - - shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, - tyCoVarsOfCo, tyCoVarsOfCos, - coVarsOfType, coVarsOfTypes, - coVarsOfCo, coVarsOfCos, - tyCoVarsOfCoDSet, - tyCoFVsOfCo, tyCoFVsOfCos, - tyCoVarsOfCoList, - - almostDevoidCoVarOfCo, - - -- Injective free vars - injectiveVarsOfType, injectiveVarsOfTypes, - invisibleVarsOfType, invisibleVarsOfTypes, - - -- No Free vars - noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, - - -- * Well-scoped free variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - - -- * Closing over kinds - closeOverKindsDSet, closeOverKindsList, - closeOverKinds, - - -- * Raw materials - Endo(..), runTyCoVars - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Type (coreView, partitionInvisibleTypes) - -import Data.Monoid as DM ( Endo(..), All(..) ) -import TyCoRep -import TyCon -import Var -import FV - -import UniqFM -import VarSet -import VarEnv -import Util -import Panic - -{- -%************************************************************************ -%* * - Free variables of types and coercions -%* * -%************************************************************************ --} - -{- Note [Shallow and deep free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definitions - -* Shallow free variables of a type: the variables - affected by substitution. Specifically, the (TyVarTy tv) - and (CoVar cv) that appear - - In the type and coercions appearing in the type - - In shallow free variables of the kind of a Forall binder - but NOT in the kind of the /occurrences/ of a type variable. - -* Deep free variables of a type: shallow free variables, plus - the deep free variables of the kinds of those variables. - That is, deepFVs( t ) = closeOverKinds( shallowFVs( t ) ) - -Examples: - - Type Shallow Deep - --------------------------------- - (a : (k:Type)) {a} {a,k} - forall (a:(k:Type)). a {k} {k} - (a:k->Type) (b:k) {a,b} {a,b,k} --} - - -{- Note [Free variables of types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns -a VarSet that is closed over the types of its variables. More precisely, - if S = tyCoVarsOfType( t ) - and (a:k) is in S - then tyCoVarsOftype( k ) is a subset of S - -Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. - -We could /not/ close over the kinds of the variable occurrences, and -instead do so at call sites, but it seems that we always want to do -so, so it's easiest to do it here. - -It turns out that getting the free variables of types is performance critical, -so we profiled several versions, exploring different implementation strategies. - -1. Baseline version: uses FV naively. Essentially: - - tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty - - This is not nice, because FV introduces some overhead to implement - determinism, and through its "interesting var" function, neither of which - we need here, so they are a complete waste. - -2. UnionVarSet version: instead of reusing the FV-based code, we simply used - VarSets directly, trying to avoid the overhead of FV. E.g.: - - -- FV version: - tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c - - -- UnionVarSet version: - tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) - - This looks deceptively similar, but while FV internally builds a list- and - set-generating function, the VarSet functions manipulate sets directly, and - the latter performs a lot worse than the naive FV version. - -3. Accumulator-style VarSet version: this is what we use now. We do use VarSet - as our data structure, but delegate the actual work to a new - ty_co_vars_of_... family of functions, which use accumulator style and the - "in-scope set" filter found in the internals of FV, but without the - determinism overhead. - -See #14880. - -Note [Closing over free variable kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over -free variable kinds. In previous GHC versions, this happened naively: whenever -we would encounter an occurrence of a free type variable, we would close over -its kind. This, however is wrong for two reasons (see #14880): - -1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then - we don't want to have to traverse k more than once. - -2. Correctness. Imagine we have forall k. b -> k, where b has - kind k, for some k bound in an outer scope. If we look at b's kind inside - the forall, we'll collect that k is free and then remove k from the set of - free variables. This is plain wrong. We must instead compute that b is free - and then conclude that b's kind is free. - -An obvious first approach is to move the closing-over-kinds from the -occurrences of a type variable to after finding the free vars - however, this -turns out to introduce performance regressions, and isn't even entirely -correct. - -In fact, it isn't even important *when* we close over kinds; what matters is -that we handle each type var exactly once, and that we do it in the right -context. - -So the next approach we tried was to use the "in-scope set" part of FV or the -equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to -say "don't bother with variables we have already closed over". This should work -fine in theory, but the code is complicated and doesn't perform well. - -But there is a simpler way, which is implemented here. Consider the two points -above: - -1. Efficiency: we now have an accumulator, so the second time we encounter 'a', - we'll ignore it, certainly not looking at its kind - this is why - pre-checking set membership before inserting ends up not only being faster, - but also being correct. - -2. Correctness: we have an "in-scope set" (I think we should call it it a - "bound-var set"), specifying variables that are bound by a forall in the type - we are traversing; we simply ignore these variables, certainly not looking at - their kind. - -So now consider: - - forall k. b -> k - -where b :: k->Type is free; but of course, it's a different k! When looking at -b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose -this is our first encounter with b; we want the free vars of its kind. But we -want to behave as if we took the free vars of its kind at the end; that is, -with no bound vars in scope. - -So the solution is easy. The old code was this: - - ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) - -Now all we need to do is take the free vars of tyVarKind v *with an empty -bound-var set*, thus: - -ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) - ^^^^^^^^^^^ - -And that's it. This works because a variable is either bound or free. If it is bound, -then we won't look at it at all. If it is free, then all the variables free in its -kind are free -- regardless of whether some local variable has the same Unique. -So if we're looking at a variable occurrence at all, then all variables in its -kind are free. --} - -{- ********************************************************************* -* * - Endo for free variables -* * -********************************************************************* -} - -{- Note [Acumulating parameter free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can use foldType to build an accumulating-parameter version of a -free-var finder, thus: - - fvs :: Type -> TyCoVarSet - fvs ty = appEndo (foldType folder ty) emptyVarSet - -Recall that - foldType :: TyCoFolder env a -> env -> Type -> a - - newtype Endo a = Endo (a -> a) -- In Data.Monoid - instance Monoid a => Monoid (Endo a) where - (Endo f) `mappend` (Endo g) = Endo (f.g) - - appEndo :: Endo a -> a -> a - appEndo (Endo f) x = f x - -So `mappend` for Endos is just function composition. - -It's very important that, after optimisation, we end up with -* an arity-three function -* that is strict in the accumulator - - fvs env (TyVarTy v) acc - | v `elemVarSet` env = acc - | v `elemVarSet` acc = acc - | otherwise = acc `extendVarSet` v - fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) - ... - -The "strict in the accumulator" part is to ensure that in the -AppTy equation we don't build a thunk for (fvs env t2 acc). - -The optimiser does do all this, but not very robustly. It depends -critially on the basic arity-2 function not being exported, so that -all its calls are visibly to three arguments. This analysis is -done by the Call Arity pass. - -TL;DR: check this regularly! --} - -runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet -{-# INLINE runTyCoVars #-} -runTyCoVars f = appEndo f emptyVarSet - -noView :: Type -> Maybe Type -noView _ = Nothing - -{- ********************************************************************* -* * - Deep free variables - See Note [Shallow and deep free variables] -* * -********************************************************************* -} - -tyCoVarsOfType :: Type -> TyCoVarSet -tyCoVarsOfType ty = runTyCoVars (deep_ty ty) --- Alternative: --- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty) - -tyCoVarsOfTypes :: [Type] -> TyCoVarSet -tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) --- Alternative: --- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) - -tyCoVarsOfCo :: Coercion -> TyCoVarSet --- See Note [Free variables of Coercions] -tyCoVarsOfCo co = runTyCoVars (deep_co co) - -tyCoVarsOfCos :: [Coercion] -> TyCoVarSet -tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) - -deep_ty :: Type -> Endo TyCoVarSet -deep_tys :: [Type] -> Endo TyCoVarSet -deep_co :: Coercion -> Endo TyCoVarSet -deep_cos :: [Coercion] -> Endo TyCoVarSet -(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet - -deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -deepTcvFolder = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_tycobinder = do_bndr } - where - do_tcv is v = Endo do_it - where - do_it acc | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = appEndo (deep_ty (varType v)) $ - acc `extendVarSet` v - - do_bndr is tcv _ = extendVarSet is tcv - do_hole is hole = do_tcv is (coHoleCoVar hole) - -- See Note [CoercionHoles and coercion free variables] - -- in TyCoRep - -{- ********************************************************************* -* * - Shallow free variables - See Note [Shallow and deep free variables] -* * -********************************************************************* -} - - -shallowTyCoVarsOfType :: Type -> TyCoVarSet --- See Note [Free variables of types] -shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty) - -shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet -shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys) - -shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet -shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) - -shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet -shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet --- See Note [Free variables of types] -shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys) - -- It's OK to use nonDetEltsUFM here because we immediately - -- forget the ordering by returning a set - -shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet -shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) - -- It's OK to use nonDetEltsUFM here because we immediately - -- forget the ordering by returning a set - -shallow_ty :: Type -> Endo TyCoVarSet -shallow_tys :: [Type] -> Endo TyCoVarSet -shallow_co :: Coercion -> Endo TyCoVarSet -shallow_cos :: [Coercion] -> Endo TyCoVarSet -(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet - -shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -shallowTcvFolder = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_tycobinder = do_bndr } - where - do_tcv is v = Endo do_it - where - do_it acc | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = acc `extendVarSet` v - - do_bndr is tcv _ = extendVarSet is tcv - do_hole _ _ = mempty -- Ignore coercion holes - - -{- ********************************************************************* -* * - Free coercion variables -* * -********************************************************************* -} - - -{- Note [Finding free coercion varibles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here we are only interested in the free /coercion/ variables. -We can achieve this through a slightly differnet TyCo folder. - -Notice that we look deeply, into kinds. - -See #14880. --} - -coVarsOfType :: Type -> CoVarSet -coVarsOfTypes :: [Type] -> CoVarSet -coVarsOfCo :: Coercion -> CoVarSet -coVarsOfCos :: [Coercion] -> CoVarSet - -coVarsOfType ty = runTyCoVars (deep_cv_ty ty) -coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) -coVarsOfCo co = runTyCoVars (deep_cv_co co) -coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) - -deep_cv_ty :: Type -> Endo CoVarSet -deep_cv_tys :: [Type] -> Endo CoVarSet -deep_cv_co :: Coercion -> Endo CoVarSet -deep_cv_cos :: [Coercion] -> Endo CoVarSet -(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet - -deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) -deepCoVarFolder = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tyvar, tcf_covar = do_covar - , tcf_hole = do_hole, tcf_tycobinder = do_bndr } - where - do_tyvar _ _ = mempty - -- This do_tyvar means we won't see any CoVars in this - -- TyVar's kind. This may be wrong; but it's the way it's - -- always been. And its awkward to change, because - -- the tyvar won't end up in the accumulator, so - -- we'd look repeatedly. Blargh. - - do_covar is v = Endo do_it - where - do_it acc | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = appEndo (deep_cv_ty (varType v)) $ - acc `extendVarSet` v - - do_bndr is tcv _ = extendVarSet is tcv - do_hole is hole = do_covar is (coHoleCoVar hole) - -- See Note [CoercionHoles and coercion free variables] - -- in TyCoRep - - -{- ********************************************************************* -* * - Closing over kinds -* * -********************************************************************* -} - -------------- Closing over kinds ----------------- - -closeOverKinds :: TyCoVarSet -> TyCoVarSet --- For each element of the input set, --- add the deep free variables of its kind -closeOverKinds vs = nonDetFoldVarSet do_one vs vs - where - do_one v acc = appEndo (deep_ty (varType v)) acc - -{- --------------- Alternative version 1 (using FV) ------------ -closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet --} - -{- ---------------- Alternative version 2 ------------- - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a non-deterministic set. -closeOverKinds :: TyCoVarSet -> TyCoVarSet -closeOverKinds vs - = go vs vs - where - go :: VarSet -- Work list - -> VarSet -- Accumulator, always a superset of wl - -> VarSet - go wl acc - | isEmptyVarSet wl = acc - | otherwise = go wl_kvs (acc `unionVarSet` wl_kvs) - where - k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc - wl_kvs = nonDetFoldVarSet k emptyVarSet wl - -- wl_kvs = union of shallow free vars of the kinds of wl - -- but don't bother to collect vars in acc - --} - -{- ---------------- Alternative version 3 ------------- --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a non-deterministic set. -closeOverKinds :: TyVarSet -> TyVarSet -closeOverKinds vs = close_over_kinds vs emptyVarSet - - -close_over_kinds :: TyVarSet -- Work list - -> TyVarSet -- Accumulator - -> TyVarSet --- Precondition: in any call (close_over_kinds wl acc) --- for every tv in acc, the shallow kind-vars of tv --- are either in the work list wl, or in acc --- Postcondition: result is the deep free vars of (wl `union` acc) -close_over_kinds wl acc - = nonDetFoldVarSet do_one acc wl - where - do_one :: Var -> TyVarSet -> TyVarSet - -- (do_one v acc) adds v and its deep free-vars to acc - do_one v acc | v `elemVarSet` acc - = acc - | otherwise - = close_over_kinds (shallowTyCoVarsOfType (varType v)) $ - acc `extendVarSet` v --} - - -{- ********************************************************************* -* * - The FV versions return deterministic results -* * -********************************************************************* -} - --- | Given a list of tyvars returns a deterministic FV computation that --- returns the given tyvars with the kind variables free in the kinds of the --- given tyvars. -closeOverKindsFV :: [TyVar] -> FV -closeOverKindsFV tvs = - mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministically ordered list. -closeOverKindsList :: [TyVar] -> [TyVar] -closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems - --- | `tyCoFVsOfType` that returns free variables of a type in a deterministic --- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty - --- | `tyCoFVsOfType` that returns free variables of a type in deterministic --- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeList :: Type -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty - --- | Returns free variables of types, including kind variables as --- a deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys - --- | Returns free variables of types, including kind variables as --- a deterministically ordered list. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesList :: [Type] -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys - --- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. --- The previous implementation used `unionVarSet` which is O(n+m) and can --- make the function quadratic. --- It's exported, so that it can be composed with --- other functions that compute free variables. --- See Note [FV naming conventions] in FV. --- --- Eta-expanded because that makes it run faster (apparently) --- See Note [FV eta expansion] in FV for explanation. -tyCoFVsOfType :: Type -> FV --- See Note [Free variables of types] -tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) - | not (f v) = (acc_list, acc_set) - | v `elemVarSet` bound_vars = (acc_list, acc_set) - | v `elemVarSet` acc_set = (acc_list, acc_set) - | otherwise = tyCoFVsOfType (tyVarKind v) f - emptyVarSet -- See Note [Closing over free variable kinds] - (v:acc_list, extendVarSet acc_set v) -tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc -tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc -tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc -tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc -tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc -tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc -tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc - -tyCoFVsBndr :: TyCoVarBinder -> FV -> FV --- Free vars of (forall b. ) -tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs - -tyCoFVsVarBndrs :: [Var] -> FV -> FV -tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars - -tyCoFVsVarBndr :: Var -> FV -> FV -tyCoFVsVarBndr var fvs - = tyCoFVsOfType (varType var) -- Free vars of its type/kind - `unionFV` delFV var fvs -- Delete it from the thing-inside - -tyCoFVsOfTypes :: [Type] -> FV --- See Note [Free variables of types] -tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc -tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc - --- | Get a deterministic set of the vars free in a coercion -tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co - -tyCoVarsOfCoList :: Coercion -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co - -tyCoFVsOfMCo :: MCoercion -> FV -tyCoFVsOfMCo MRefl = emptyFV -tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co - -tyCoFVsOfCo :: Coercion -> FV --- Extracts type and coercion variables from a coercion --- See Note [Free variables of types] -tyCoFVsOfCo (Refl ty) fv_cand in_scope acc - = tyCoFVsOfType ty fv_cand in_scope acc -tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc - = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc -tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc - = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc - = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc -tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc - = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc - = tyCoFVsOfCoVar v fv_cand in_scope acc -tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc - = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc - -- See Note [CoercionHoles and coercion free variables] -tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc - = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 - `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc -tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc - -tyCoFVsOfCoVar :: CoVar -> FV -tyCoFVsOfCoVar v fv_cand in_scope acc - = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc - -tyCoFVsOfProv :: UnivCoProvenance -> FV -tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc - -tyCoFVsOfCos :: [Coercion] -> FV -tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc - - ------ Whether a covar is /Almost Devoid/ in a type or coercion ---- - --- | Given a covar and a coercion, returns True if covar is almost devoid in --- the coercion. That is, covar can only appear in Refl and GRefl. --- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion -almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool -almostDevoidCoVarOfCo cv co = - almost_devoid_co_var_of_co co cv - -almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool -almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and -almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into - -- the coercions -almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (AppCo co arg) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_co arg cv -almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv - = almost_devoid_co_var_of_co kind_co cv - && (v == cv || almost_devoid_co_var_of_co co cv) -almost_devoid_co_var_of_co (FunCo _ co1 co2) cv - = almost_devoid_co_var_of_co co1 cv - && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv -almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv -almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv - = almost_devoid_co_var_of_prov p cv - && almost_devoid_co_var_of_type t1 cv - && almost_devoid_co_var_of_type t2 cv -almost_devoid_co_var_of_co (SymCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (TransCo co1 co2) cv - = almost_devoid_co_var_of_co co1 cv - && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (NthCo _ _ co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (LRCo _ co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (InstCo co arg) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_co arg cv -almost_devoid_co_var_of_co (KindCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (SubCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv - = almost_devoid_co_var_of_cos cs cv - -almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool -almost_devoid_co_var_of_cos [] _ = True -almost_devoid_co_var_of_cos (co:cos) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_cos cos cv - -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool -almost_devoid_co_var_of_prov (PhantomProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (ProofIrrelProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (PluginProv _) _ = True - -almost_devoid_co_var_of_type :: Type -> CoVar -> Bool -almost_devoid_co_var_of_type (TyVarTy _) _ = True -almost_devoid_co_var_of_type (TyConApp _ tys) cv - = almost_devoid_co_var_of_types tys cv -almost_devoid_co_var_of_type (LitTy {}) _ = True -almost_devoid_co_var_of_type (AppTy fun arg) cv - = almost_devoid_co_var_of_type fun cv - && almost_devoid_co_var_of_type arg cv -almost_devoid_co_var_of_type (FunTy _ arg res) cv - = almost_devoid_co_var_of_type arg cv - && almost_devoid_co_var_of_type res cv -almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv - = almost_devoid_co_var_of_type (varType v) cv - && (v == cv || almost_devoid_co_var_of_type ty cv) -almost_devoid_co_var_of_type (CastTy ty co) cv - = almost_devoid_co_var_of_type ty cv - && almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_type (CoercionTy co) cv - = almost_devoid_co_var_of_co co cv - -almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool -almost_devoid_co_var_of_types [] _ = True -almost_devoid_co_var_of_types (ty:tys) cv - = almost_devoid_co_var_of_type ty cv - && almost_devoid_co_var_of_types tys cv - - - -{- ********************************************************************* -* * - Injective free vars -* * -********************************************************************* -} - --- | Returns the free variables of a 'Type' that are in injective positions. --- Specifically, it finds the free variables while: --- --- * Expanding type synonyms --- --- * Ignoring the coercion in @(ty |> co)@ --- --- * Ignoring the non-injective fields of a 'TyConApp' --- --- --- For example, if @F@ is a non-injective type family, then: --- --- @ --- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} --- @ --- --- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. --- More formally, if --- @a@ is in @'injectiveVarsOfType' ty@ --- and @S1(ty) ~ S2(ty)@, --- then @S1(a) ~ S2(a)@, --- where @S1@ and @S2@ are arbitrary substitutions. --- --- See @Note [When does a tycon application need an explicit kind signature?]@. -injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? - -- See Note [Coverage condition for injective type families] - -- in FamInst. - -> Type -> FV -injectiveVarsOfType look_under_tfs = go - where - go ty | Just ty' <- coreView ty - = go ty' - go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) - go (AppTy f a) = go f `unionFV` go a - go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 - go (TyConApp tc tys) = - case tyConInjectivityInfo tc of - Injective inj - | look_under_tfs || not (isTypeFamilyTyCon tc) - -> mapUnionFV go $ - filterByList (inj ++ repeat True) tys - -- Oversaturated arguments to a tycon are - -- always injective, hence the repeat True - _ -> emptyFV - go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) - go LitTy{} = emptyFV - go (CastTy ty _) = go ty - go CoercionTy{} = emptyFV - --- | Returns the free variables of a 'Type' that are in injective positions. --- Specifically, it finds the free variables while: --- --- * Expanding type synonyms --- --- * Ignoring the coercion in @(ty |> co)@ --- --- * Ignoring the non-injective fields of a 'TyConApp' --- --- See @Note [When does a tycon application need an explicit kind signature?]@. -injectiveVarsOfTypes :: Bool -- ^ look under injective type families? - -- See Note [Coverage condition for injective type families] - -- in FamInst. - -> [Type] -> FV -injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) - - -{- ********************************************************************* -* * - Invisible vars -* * -********************************************************************* -} - - --- | Returns the set of variables that are used invisibly anywhere within --- the given type. A variable will be included even if it is used both visibly --- and invisibly. An invisible use site includes: --- * In the kind of a variable --- * In the kind of a bound variable in a forall --- * In a coercion --- * In a Specified or Inferred argument to a function --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep -invisibleVarsOfType :: Type -> FV -invisibleVarsOfType = go - where - go ty | Just ty' <- coreView ty - = go ty' - go (TyVarTy v) = go (tyVarKind v) - go (AppTy f a) = go f `unionFV` go a - go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 - go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` - invisibleVarsOfTypes visibles - where (invisibles, visibles) = partitionInvisibleTypes tc tys - go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty - go LitTy{} = emptyFV - go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty - go (CoercionTy co) = tyCoFVsOfCo co - --- | Like 'invisibleVarsOfType', but for many types. -invisibleVarsOfTypes :: [Type] -> FV -invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType - - -{- ********************************************************************* -* * - No free vars -* * -********************************************************************* -} - -nfvFolder :: TyCoFolder TyCoVarSet DM.All -nfvFolder = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_tycobinder = do_bndr } - where - do_tcv is tv = All (tv `elemVarSet` is) - do_hole _ _ = All True -- I'm unsure; probably never happens - do_bndr is tv _ = is `extendVarSet` tv - -nfv_ty :: Type -> DM.All -nfv_tys :: [Type] -> DM.All -nfv_co :: Coercion -> DM.All -(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet - -noFreeVarsOfType :: Type -> Bool -noFreeVarsOfType ty = DM.getAll (nfv_ty ty) - -noFreeVarsOfTypes :: [Type] -> Bool -noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys) - -noFreeVarsOfCo :: Coercion -> Bool -noFreeVarsOfCo co = getAll (nfv_co co) - - -{- ********************************************************************* -* * - scopedSort -* * -********************************************************************* -} - -{- Note [ScopedSort] -~~~~~~~~~~~~~~~~~~~~ -Consider - - foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () - -This function type is implicitly generalised over [a, b, k, k2]. These -variables will be Specified; that is, they will be available for visible -type application. This is because they are written in the type signature -by the user. - -However, we must ask: what order will they appear in? In cases without -dependency, this is easy: we just use the lexical left-to-right ordering -of first occurrence. With dependency, we cannot get off the hook so -easily. - -We thus state: - - * These variables appear in the order as given by ScopedSort, where - the input to ScopedSort is the left-to-right order of first occurrence. - -Note that this applies only to *implicit* quantification, without a -`forall`. If the user writes a `forall`, then we just use the order given. - -ScopedSort is defined thusly (as proposed in #15743): - * Work left-to-right through the input list, with a cursor. - * If variable v at the cursor is depended on by any earlier variable w, - move v immediately before the leftmost such w. - -INVARIANT: The prefix of variables before the cursor form a valid telescope. - -Note that ScopedSort makes sense only after type inference is done and all -types/kinds are fully settled and zonked. - --} - --- | Do a topological sort on a list of tyvars, --- so that binders occur before occurrences --- E.g. given [ a::k, k::*, b::k ] --- it'll return a well-scoped list [ k::*, a::k, b::k ] --- --- This is a deterministic sorting operation --- (that is, doesn't depend on Uniques). --- --- It is also meant to be stable: that is, variables should not --- be reordered unnecessarily. This is specified in Note [ScopedSort] --- See also Note [Ordering of implicit variables] in GHC.Rename.Types - -scopedSort :: [TyCoVar] -> [TyCoVar] -scopedSort = go [] [] - where - go :: [TyCoVar] -- already sorted, in reverse order - -> [TyCoVarSet] -- each set contains all the variables which must be placed - -- before the tv corresponding to the set; they are accumulations - -- of the fvs in the sorted tvs' kinds - - -- This list is in 1-to-1 correspondence with the sorted tyvars - -- INVARIANT: - -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) - -- That is, each set in the list is a superset of all later sets. - - -> [TyCoVar] -- yet to be sorted - -> [TyCoVar] - go acc _fv_list [] = reverse acc - go acc fv_list (tv:tvs) - = go acc' fv_list' tvs - where - (acc', fv_list') = insert tv acc fv_list - - insert :: TyCoVar -- var to insert - -> [TyCoVar] -- sorted list, in reverse order - -> [TyCoVarSet] -- list of fvs, as above - -> ([TyCoVar], [TyCoVarSet]) -- augmented lists - insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) - insert tv (a:as) (fvs:fvss) - | tv `elemVarSet` fvs - , (as', fvss') <- insert tv as fvss - = (a:as', fvs `unionVarSet` fv_tv : fvss') - - | otherwise - = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) - where - fv_tv = tyCoVarsOfType (tyVarKind tv) - - -- lists not in correspondence - insert _ _ _ = panic "scopedSort" - --- | Get the free vars of a type in scoped order -tyCoVarsOfTypeWellScoped :: Type -> [TyVar] -tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList - --- | Get the free vars of types in scoped order -tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList - diff --git a/compiler/types/TyCoPpr.hs b/compiler/types/TyCoPpr.hs deleted file mode 100644 --- a/compiler/types/TyCoPpr.hs +++ /dev/null @@ -1,340 +0,0 @@ --- | Pretty-printing types and coercions. -module TyCoPpr - ( - -- * Precedence - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, - - -- * Pretty-printing types - pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX, - pprTypeApp, pprTCvBndr, pprTCvBndrs, - pprSigmaType, - pprTheta, pprParendTheta, pprForAll, pprUserForAll, - pprTyVar, pprTyVars, - pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprTyLit, - pprDataCons, pprWithExplicitKindsWhen, - pprWithTYPE, pprSourceTyCon, - - - -- * Pretty-printing coercions - pprCo, pprParendCo, - - debugPprType, - - -- * Pretty-printing 'TyThing's - pprTyThingCategory, pprShortTyThing, - ) where - -import GhcPrelude - -import {-# SOURCE #-} GHC.CoreToIface - ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr - , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) - -import {-# SOURCE #-} DataCon( dataConFullSig - , dataConUserTyVarBinders - , DataCon ) - -import {-# SOURCE #-} Type( isLiftedTypeKind ) - -import TyCon -import TyCoRep -import TyCoTidy -import TyCoFVs -import Class -import Var - -import GHC.Iface.Type - -import VarSet -import VarEnv - -import Outputable -import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec - , funPrec, appPrec, maybeParen ) - -{- -%************************************************************************ -%* * - Pretty-printing types - - Defined very early because of debug printing in assertions -%* * -%************************************************************************ - -@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is -defined to use this. @pprParendType@ is the same, except it puts -parens around the type, except for the atomic cases. @pprParendType@ -works just by setting the initial context precedence very high. - -Note that any function which pretty-prints a @Type@ first converts the @Type@ -to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. - -See Note [Precedence in types] in BasicTypes. --} - --------------------------------------------------------- --- When pretty-printing types, we convert to IfaceType, --- and pretty-print that. --- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing --------------------------------------------------------- - -pprType, pprParendType, pprTidiedType :: Type -> SDoc -pprType = pprPrecType topPrec -pprParendType = pprPrecType appPrec - --- already pre-tidied -pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet - -pprPrecType :: PprPrec -> Type -> SDoc -pprPrecType = pprPrecTypeX emptyTidyEnv - -pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc -pprPrecTypeX env prec ty - = getPprStyle $ \sty -> - if debugStyle sty -- Use debugPprType when in - then debug_ppr_ty prec ty -- when in debug-style - else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) - -- NB: debug-style is used for -dppr-debug - -- dump-style is used for -ddump-tc-trace etc - -pprTyLit :: TyLit -> SDoc -pprTyLit = pprIfaceTyLit . toIfaceTyLit - -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - -tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType -tidyToIfaceTypeStyX env ty sty - | userStyle sty = tidyToIfaceTypeX env ty - | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty - -- in latter case, don't tidy, as we'll be printing uniques. - -tidyToIfaceType :: Type -> IfaceType -tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv - -tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceTypeX to --- leave them as IfaceFreeTyVar. This is super-important --- for debug printing. -tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) - where - env' = tidyFreeTyCoVars env free_tcvs - free_tcvs = tyCoVarsOfTypeWellScoped ty - ------------- -pprCo, pprParendCo :: Coercion -> SDoc -pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) -pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) - -tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion -tidyToIfaceCoSty co sty - | userStyle sty = tidyToIfaceCo co - | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co - -- in latter case, don't tidy, as we'll be printing uniques. - -tidyToIfaceCo :: Coercion -> IfaceCoercion --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceCoercionX to --- leave them as IfaceFreeCoVar. This is super-important --- for debug printing. -tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) - where - env = tidyFreeTyCoVars emptyTidyEnv free_tcvs - free_tcvs = scopedSort $ tyCoVarsOfCoList co ------------- -pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = pprTypeApp (classTyCon clas) tys - ------------- -pprTheta :: ThetaType -> SDoc -pprTheta = pprIfaceContext topPrec . map tidyToIfaceType - -pprParendTheta :: ThetaType -> SDoc -pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType - -pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType - ------------------- -pprSigmaType :: Type -> SDoc -pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType - -pprForAll :: [TyCoVarBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) - --- | Print a user-level forall; see Note [When to print foralls] in this module. -pprUserForAll :: [TyCoVarBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr - -pprTCvBndrs :: [TyCoVarBinder] -> SDoc -pprTCvBndrs tvs = sep (map pprTCvBndr tvs) - -pprTCvBndr :: TyCoVarBinder -> SDoc -pprTCvBndr = pprTyVar . binderVar - -pprTyVars :: [TyVar] -> SDoc -pprTyVars tvs = sep (map pprTyVar tvs) - -pprTyVar :: TyVar -> SDoc --- Print a type variable binder with its kind (but not if *) --- Here we do not go via IfaceType, because the duplication with --- pprIfaceTvBndr is minimal, and the loss of uniques etc in --- debug printing is disastrous -pprTyVar tv - | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) - where - kind = tyVarKind tv - ------------------ -debugPprType :: Type -> SDoc --- ^ debugPprType is a simple pretty printer that prints a type --- without going through IfaceType. It does not format as prettily --- as the normal route, but it's much more direct, and that can --- be useful for debugging. E.g. with -dppr-debug it prints the --- kind on type-variable /occurrences/ which the normal route --- fundamentally cannot do. -debugPprType ty = debug_ppr_ty topPrec ty - -debug_ppr_ty :: PprPrec -> Type -> SDoc -debug_ppr_ty _ (LitTy l) - = ppr l - -debug_ppr_ty _ (TyVarTy tv) - = ppr tv -- With -dppr-debug we get (tv :: kind) - -debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = maybeParen prec funPrec $ - sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] - where - arrow = case af of - VisArg -> text "->" - InvisArg -> text "=>" - -debug_ppr_ty prec (TyConApp tc tys) - | null tys = ppr tc - | otherwise = maybeParen prec appPrec $ - hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) - -debug_ppr_ty _ (AppTy t1 t2) - = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) - 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish - -- TyConApp from AppTy - -debug_ppr_ty prec (CastTy ty co) - = maybeParen prec topPrec $ - hang (debug_ppr_ty topPrec ty) - 2 (text "|>" <+> ppr co) - -debug_ppr_ty _ (CoercionTy co) - = parens (text "CO" <+> ppr co) - -debug_ppr_ty prec ty@(ForAllTy {}) - | (tvs, body) <- split ty - = maybeParen prec funPrec $ - hang (text "forall" <+> fsep (map ppr tvs) <> dot) - -- The (map ppr tvs) will print kind-annotated - -- tvs, because we are (usually) in debug-style - 2 (ppr body) - where - split ty | ForAllTy tv ty' <- ty - , (tvs, body) <- split ty' - = (tv:tvs, body) - | otherwise - = ([], ty) - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we want to print top-level foralls when (and only when) the user specifies --fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses -too much information; see #9018. - -So I'm trying out this rule: print explicit foralls if - a) User specifies -fprint-explicit-foralls, or - b) Any of the quantified type variables has a kind - that mentions a kind variable - -This catches common situations, such as a type siguature - f :: m a -which means - f :: forall k. forall (m :: k->*) (a :: k). m a -We really want to see both the "forall k" and the kind signatures -on m and a. The latter comes from pprTCvBndr. - -Note [Infix type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With TypeOperators you can say - - f :: (a ~> b) -> b - -and the (~>) is considered a type variable. However, the type -pretty-printer in this module will just see (a ~> b) as - - App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") - -So it'll print the type in prefix form. To avoid confusion we must -remember to parenthesise the operator, thus - - (~>) a b -> b - -See #2766. --} - -pprDataCons :: TyCon -> SDoc -pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons - where - sepWithVBars [] = empty - sepWithVBars docs = sep (punctuate (space <> vbar) docs) - -pprDataConWithArgs :: DataCon -> SDoc -pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] - where - (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - user_bndrs = dataConUserTyVarBinders dc - forAllDoc = pprUserForAll user_bndrs - thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) - - -pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys - = pprIfaceTypeApp topPrec (toIfaceTyCon tc) - (toIfaceTcArgs tc tys) - -- TODO: toIfaceTcArgs seems rather wasteful here - ------------------- --- | Display all kind information (with @-fprint-explicit-kinds@) when the --- provided 'Bool' argument is 'True'. --- See @Note [Kind arguments in error messages]@ in TcErrors. -pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc -pprWithExplicitKindsWhen b - = updSDocContext $ \ctx -> - if b then ctx { sdocPrintExplicitKinds = True } - else ctx - --- | This variant preserves any use of TYPE in a type, effectively --- locally setting -fprint-explicit-runtime-reps. -pprWithTYPE :: Type -> SDoc -pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $ - ppr ty - --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > data T [a] = ... --- --- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' -pprSourceTyCon :: TyCon -> SDoc -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon diff --git a/compiler/types/TyCoPpr.hs-boot b/compiler/types/TyCoPpr.hs-boot deleted file mode 100644 --- a/compiler/types/TyCoPpr.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module TyCoPpr where - -import {-# SOURCE #-} TyCoRep (Type, Kind, Coercion, TyLit) -import Outputable - -pprType :: Type -> SDoc -pprKind :: Kind -> SDoc -pprCo :: Coercion -> SDoc -pprTyLit :: TyLit -> SDoc - diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs deleted file mode 100644 --- a/compiler/types/TyCoRep.hs +++ /dev/null @@ -1,1848 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 -\section[TyCoRep]{Type and Coercion - friends' interface} - -Note [The Type-related module hierarchy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Class - CoAxiom - TyCon imports Class, CoAxiom - TyCoRep imports Class, CoAxiom, TyCon - TyCoPpr imports TyCoRep - TyCoFVs imports TyCoRep - TyCoSubst imports TyCoRep, TyCoFVs, TyCoPpr - TyCoTidy imports TyCoRep, TyCoFVs - TysPrim imports TyCoRep ( including mkTyConTy ) - Coercion imports Type --} - --- We expose the relevant stuff from this module via the Type module -{-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} - -module TyCoRep ( - TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, - - -- * Types - Type( TyVarTy, AppTy, TyConApp, ForAllTy - , LitTy, CastTy, CoercionTy - , FunTy, ft_arg, ft_res, ft_af - ), -- Export the type synonym FunTy too - - TyLit(..), - KindOrType, Kind, - KnotTied, - PredType, ThetaType, -- Synonyms - ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - - -- * Coercions - Coercion(..), - UnivCoProvenance(..), - CoercionHole(..), coHoleCoVar, setCoHoleCoVar, - CoercionN, CoercionR, CoercionP, KindCoercion, - MCoercion(..), MCoercionR, MCoercionN, - - -- * Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, - mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, - mkForAllTy, mkForAllTys, - mkPiTy, mkPiTys, - - -- * Functions over binders - TyCoBinder(..), TyCoVarBinder, TyBinder, - binderVar, binderVars, binderType, binderArgFlag, - delBinderVar, - isInvisibleArgFlag, isVisibleArgFlag, - isInvisibleBinder, isVisibleBinder, - isTyBinder, isNamedBinder, - - -- * Functions over coercions - pickLR, - - -- ** Analyzing types - TyCoFolder(..), foldTyCo, - - -- * Sizes - typeSize, coercionSize, provSize - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCoPpr ( pprType, pprCo, pprTyLit ) - - -- Transitively pulls in a LOT of stuff, better to break the loop - -import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) - --- friends: -import GHC.Iface.Type -import Var -import VarSet -import Name hiding ( varName ) -import TyCon -import CoAxiom - --- others -import BasicTypes ( LeftOrRight(..), pickLR ) -import Outputable -import FastString -import Util - --- libraries -import qualified Data.Data as Data hiding ( TyCon ) -import Data.IORef ( IORef ) -- for CoercionHole - -{- -%************************************************************************ -%* * - TyThing -%* * -%************************************************************************ - -Despite the fact that DataCon has to be imported via a hi-boot route, -this module seems the right place for TyThing, because it's needed for -funTyCon and all the types in TysPrim. - -It is also SOURCE-imported into Name.hs - - -Note [ATyCon for classes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Both classes and type constructors are represented in the type environment -as ATyCon. You can tell the difference, and get to the class, with - isClassTyCon :: TyCon -> Bool - tyConClass_maybe :: TyCon -> Maybe Class -The Class and its associated TyCon have the same Name. --} - --- | A global typecheckable-thing, essentially anything that has a name. --- Not to be confused with a 'TcTyThing', which is also a typecheckable --- thing but in the *local* context. See 'TcEnv' for how to retrieve --- a 'TyThing' given a 'Name'. -data TyThing - = AnId Id - | AConLike ConLike - | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] - | ACoAxiom (CoAxiom Branched) - -instance Outputable TyThing where - ppr = pprShortTyThing - -instance NamedThing TyThing where -- Can't put this with the type - getName (AnId id) = getName id -- decl, because the DataCon instance - getName (ATyCon tc) = getName tc -- isn't visible there - getName (ACoAxiom cc) = getName cc - getName (AConLike cl) = conLikeName cl - -pprShortTyThing :: TyThing -> SDoc --- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details -pprShortTyThing thing - = pprTyThingCategory thing <+> quotes (ppr (getName thing)) - -pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory = text . capitalise . tyThingCategory - -tyThingCategory :: TyThing -> String -tyThingCategory (ATyCon tc) - | isClassTyCon tc = "class" - | otherwise = "type constructor" -tyThingCategory (ACoAxiom _) = "coercion axiom" -tyThingCategory (AnId _) = "identifier" -tyThingCategory (AConLike (RealDataCon _)) = "data constructor" -tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" - - -{- ********************************************************************** -* * - Type -* * -********************************************************************** -} - --- | The key representation of types within the compiler - -type KindOrType = Type -- See Note [Arguments to type constructors] - --- | The key type representing kinds in the compiler. -type Kind = Type - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -data Type - -- See Note [Non-trivial definitional equality] - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', - -- must be another 'AppTy', or 'TyVarTy' - -- See Note [Respecting definitional equality] (EQ1) about the - -- no 'CastTy' requirement - -- - -- 2) Argument type - - | TyConApp - TyCon - [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. - -- Invariant: saturated applications of 'FunTyCon' must - -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's - -- do appear as 'TyConApp's. - -- Parameters: - -- - -- 1) Type constructor being applied to. - -- - -- 2) Type arguments. Might not have enough type arguments - -- here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; - -- for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. - - | ForAllTy - {-# UNPACK #-} !TyCoVarBinder - Type -- ^ A Π type. - - | FunTy -- ^ t1 -> t2 Very common, so an important special case - -- See Note [Function types] - { ft_af :: AnonArgFlag -- Is this (->) or (=>)? - , ft_arg :: Type -- Argument type - , ft_res :: Type } -- Result type - - | LitTy TyLit -- ^ Type literals are similar to type constructors. - - | CastTy - Type - KindCoercion -- ^ A kind cast. The coercion is always nominal. - -- INVARIANT: The cast is never refl. - -- INVARIANT: The Type is not a CastTy (use TransCo instead) - -- See Note [Respecting definitional equality] (EQ2) and (EQ3) - - | CoercionTy - Coercion -- ^ Injection of a Coercion into a type - -- This should only ever be used in the RHS of an AppTy, - -- in the list of a TyConApp, when applying a promoted - -- GADT data constructor - - deriving Data.Data - -instance Outputable Type where - ppr = pprType - --- NOTE: Other parts of the code assume that type literals do not contain --- types or type variables. -data TyLit - = NumTyLit Integer - | StrTyLit FastString - deriving (Eq, Ord, Data.Data) - -instance Outputable TyLit where - ppr = pprTyLit - -{- Note [Function types] -~~~~~~~~~~~~~~~~~~~~~~~~ -FFunTy is the constructor for a function type. Lots of things to say -about it! - -* FFunTy is the data constructor, meaning "full function type". - -* The function type constructor (->) has kind - (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep - mkTyConApp ensure that we convert a saturated application - TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 - dropping the 'r1' and 'r2' arguments; they are easily recovered - from 't1' and 't2'. - -* The ft_af field says whether or not this is an invisible argument - VisArg: t1 -> t2 Ordinary function type - InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, - i.e. t1 :: Constraint - See Note [Types for coercions, predicates, and evidence] - - This visibility info makes no difference in Core; it matters - only when we regard the type as a Haskell source type. - -* FunTy is a (unidirectional) pattern synonym that allows - positional pattern matching (FunTy arg res), ignoring the - ArgFlag. --} - -{- ----------------------- - Commented out until the pattern match - checker can handle it; see #16185 - - For now we use the CPP macro #define FunTy FFunTy _ - (see HsVersions.h) to allow pattern matching on a - (positional) FunTy constructor. - -{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp - , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} - --- | 'FunTy' is a (uni-directional) pattern synonym for the common --- case where we want to match on the argument/result type, but --- ignoring the AnonArgFlag -pattern FunTy :: Type -> Type -> Type -pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } - - End of commented out block ----------------------------------- -} - -{- Note [Types for coercions, predicates, and evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat differently: - - (a) Predicate types - Test: isPredTy - Binders: DictIds - Kind: Constraint - Examples: (Eq a), and (a ~ b) - - (b) Coercion types are primitive, unboxed equalities - Test: isCoVarTy - Binders: CoVars (can appear in coercions) - Kind: TYPE (TupleRep []) - Examples: (t1 ~# t2) or (t1 ~R# t2) - - (c) Evidence types is the type of evidence manipulated by - the type constraint solver. - Test: isEvVarType - Binders: EvVars - Kind: Constraint or TYPE (TupleRep []) - Examples: all coercion types and predicate types - -Coercion types and predicate types are mutually exclusive, -but evidence types are a superset of both. - -When treated as a user type, - - - Predicates (of kind Constraint) are invisible and are - implicitly instantiated - - - Coercion types, and non-pred evidence types (i.e. not - of kind Constrain), are just regular old types, are - visible, and are not implicitly instantiated. - -In a FunTy { ft_af = InvisArg }, the argument type is always -a Predicate type. - -Note [Constraints in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do we allow a type constructor to have a kind like - S :: Eq a => a -> Type - -No, we do not. Doing so would mean would need a TyConApp like - S @k @(d :: Eq k) (ty :: k) - and we have no way to build, or decompose, evidence like - (d :: Eq k) at the type level. - -But we admit one exception: equality. We /do/ allow, say, - MkT :: (a ~ b) => a -> b -> Type a b - -Why? Because we can, without much difficulty. Moreover -we can promote a GADT data constructor (see TyCon -Note [Promoted data constructors]), like - data GT a b where - MkGT : a -> a -> GT a a -so programmers might reasonably expect to be able to -promote MkT as well. - -How does this work? - -* In TcValidity.checkConstraintsOK we reject kinds that - have constraints other than (a~b) and (a~~b). - -* In Inst.tcInstInvisibleTyBinder we instantiate a call - of MkT by emitting - [W] co :: alpha ~# beta - and producing the elaborated term - MkT @alpha @beta (Eq# alpha beta co) - We don't generate a boxed "Wanted"; we generate only a - regular old /unboxed/ primitive-equality Wanted, and build - the box on the spot. - -* How can we get such a MkT? By promoting a GADT-style data - constructor - data T a b where - MkT :: (a~b) => a -> b -> T a b - See DataCon.mkPromotedDataCon - and Note [Promoted data constructors] in TyCon - -* We support both homogeneous (~) and heterogeneous (~~) - equality. (See Note [The equality types story] - in TysPrim for a primer on these equality types.) - -* How do we prevent a MkT having an illegal constraint like - Eq a? We check for this at use-sites; see TcHsType.tcTyVar, - specifically dc_theta_illegal_constraint. - -* Notice that nothing special happens if - K :: (a ~# b) => blah - because (a ~# b) is not a predicate type, and is never - implicitly instantiated. (Mind you, it's not clear how you - could creates a type constructor with such a kind.) See - Note [Types for coercions, predicates, and evidence] - -* The existence of promoted MkT with an equality-constraint - argument is the (only) reason that the AnonTCB constructor - of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). - For example, when we promote the data constructor - MkT :: forall a b. (a~b) => a -> b -> T a b - we get a PromotedDataCon with tyConBinders - Bndr (a :: Type) (NamedTCB Inferred) - Bndr (b :: Type) (NamedTCB Inferred) - Bndr (_ :: a ~ b) (AnonTCB InvisArg) - Bndr (_ :: a) (AnonTCB VisArg)) - Bndr (_ :: b) (AnonTCB VisArg)) - -* One might reasonably wonder who *unpacks* these boxes once they are - made. After all, there is no type-level `case` construct. The - surprising answer is that no one ever does. Instead, if a GADT - constructor is used on the left-hand side of a type family equation, - that occurrence forces GHC to unify the types in question. For - example: - - data G a where - MkG :: G Bool - - type family F (x :: G a) :: a where - F MkG = False - - When checking the LHS `F MkG`, GHC sees the MkG constructor and then must - unify F's implicit parameter `a` with Bool. This succeeds, making the equation - - F Bool (MkG @Bool ) = False - - Note that we never need unpack the coercion. This is because type - family equations are *not* parametric in their kind variables. That - is, we could have just said - - type family H (x :: G a) :: a where - H _ = False - - The presence of False on the RHS also forces `a` to become Bool, - giving us - - H Bool _ = False - - The fact that any of this works stems from the lack of phase - separation between types and kinds (unlike the very present phase - separation between terms and types). - - Once we have the ability to pattern-match on types below top-level, - this will no longer cut it, but it seems fine for now. - - -Note [Arguments to type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of kind polymorphism, in addition to type application we now -have kind instantiation. We reuse the same notations to do so. - -For example: - - Just (* -> *) Maybe - Right * Nat Zero - -are represented by: - - TyConApp (PromotedDataCon Just) [* -> *, Maybe] - TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] - -Important note: Nat is used as a *kind* and not as a type. This can be -confusing, since type-level Nat and kind-level Nat are identical. We -use the kind of (PromotedDataCon Right) to know if its arguments are -kinds or types. - -This kind instantiation only happens in TyConApp currently. - -Note [Non-trivial definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is Int |> <*> the same as Int? YES! In order to reduce headaches, -we decide that any reflexive casts in types are just ignored. -(Indeed they must be. See Note [Respecting definitional equality].) -More generally, the `eqType` function, which defines Core's type equality -relation, ignores casts and coercion arguments, as long as the -two types have the same kind. This allows us to be a little sloppier -in keeping track of coercions, which is a good thing. It also means -that eqType does not depend on eqCoercion, which is also a good thing. - -Why is this sensible? That is, why is something different than α-equivalence -appropriate for the implementation of eqType? - -Anything smaller than ~ and homogeneous is an appropriate definition for -equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any -expression of type τ can be transmuted to one of type σ at any point by -casting. The same is true of expressions of type σ. So in some sense, τ and σ -are interchangeable. - -But let's be more precise. If we examine the typing rules of FC (say, those in -https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) -there are several places where the same metavariable is used in two different -premises to a rule. (For example, see Ty_App.) There is an implicit equality -check here. What definition of equality should we use? By convention, we use -α-equivalence. Take any rule with one (or more) of these implicit equality -checks. Then there is an admissible rule that uses ~ instead of the implicit -check, adding in casts as appropriate. - -The only problem here is that ~ is heterogeneous. To make the kinds work out -in the admissible rule that uses ~, it is necessary to homogenize the -coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; -we use η |> kind η, which is homogeneous. - -The effect of this all is that eqType, the implementation of the implicit -equality check, can use any homogeneous relation that is smaller than ~, as -those rules must also be admissible. - -A more drawn out argument around all of this is presented in Section 7.2 of -Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). - -What would go wrong if we insisted on the casts matching? See the beginning of -Section 8 in the unpublished paper above. Theoretically, nothing at all goes -wrong. But in practical terms, getting the coercions right proved to be -nightmarish. And types would explode: during kind-checking, we often produce -reflexive kind coercions. When we try to cast by these, mkCastTy just discards -them. But if we used an eqType that distinguished between Int and Int |> <*>, -then we couldn't discard -- the output of kind-checking would be enormous, -and we would need enormous casts with lots of CoherenceCo's to straighten -them out. - -Would anything go wrong if eqType respected type families? No, not at all. But -that makes eqType rather hard to implement. - -Thus, the guideline for eqType is that it should be the largest -easy-to-implement relation that is still smaller than ~ and homogeneous. The -precise choice of relation is somewhat incidental, as long as the smart -constructors and destructors in Type respect whatever relation is chosen. - -Another helpful principle with eqType is this: - - (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. - -This principle also tells us that eqType must relate only types with the -same kinds. - -Note [Respecting definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [Non-trivial definitional equality] introduces the property (EQ). -How is this upheld? - -Any function that pattern matches on all the constructors will have to -consider the possibility of CastTy. Presumably, those functions will handle -CastTy appropriately and we'll be OK. - -More dangerous are the splitXXX functions. Let's focus on splitTyConApp. -We don't want it to fail on (T a b c |> co). Happily, if we have - (T a b c |> co) `eqType` (T d e f) -then co must be reflexive. Why? eqType checks that the kinds are equal, as -well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). -By the kind check, we know that (T a b c |> co) and (T d e f) have the same -kind. So the only way that co could be non-reflexive is for (T a b c) to have -a different kind than (T d e f). But because T's kind is closed (all tycon kinds -are closed), the only way for this to happen is that one of the arguments has -to differ, leading to a contradiction. Thus, co is reflexive. - -Accordingly, by eliminating reflexive casts, splitTyConApp need not worry -about outermost casts to uphold (EQ). Eliminating reflexive casts is done -in mkCastTy. - -Unforunately, that's not the end of the story. Consider comparing - (T a b c) =? (T a b |> (co -> )) (c |> co) -These two types have the same kind (Type), but the left type is a TyConApp -while the right type is not. To handle this case, we say that the right-hand -type is ill-formed, requiring an AppTy never to have a casted TyConApp -on its left. It is easy enough to pull around the coercions to maintain -this invariant, as done in Type.mkAppTy. In the example above, trying to -form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). -Both the casts there are reflexive and will be dropped. Huzzah. - -This idea of pulling coercions to the right works for splitAppTy as well. - -However, there is one hiccup: it's possible that a coercion doesn't relate two -Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, -then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't -be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not -`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate -our (EQ) property. - -Lastly, in order to detect reflexive casts reliably, we must make sure not -to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). - -In sum, in order to uphold (EQ), we need the following three invariants: - - (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable - cast is one that relates either a FunTy to a FunTy or a - ForAllTy to a ForAllTy. - (EQ2) No reflexive casts in CastTy. - (EQ3) No nested CastTys. - (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). - See Note [Weird typing rule for ForAllTy] in Type. - -These invariants are all documented above, in the declaration for Type. - -Note [Unused coercion variable in ForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - \(co:t1 ~ t2). e - -What type should we give to this expression? - (1) forall (co:t1 ~ t2) -> t - (2) (t1 ~ t2) -> t - -If co is used in t, (1) should be the right choice. -if co is not used in t, we would like to have (1) and (2) equivalent. - -However, we want to keep eqType simple and don't want eqType (1) (2) to return -True in any case. - -We decide to always construct (2) if co is not used in t. - -Thus in mkLamType, we check whether the variable is a coercion -variable (of type (t1 ~# t2), and whether it is un-used in the -body. If so, it returns a FunTy instead of a ForAllTy. - -There are cases we want to skip the check. For example, the check is -unnecessary when it is known from the context that the input variable -is a type variable. In those cases, we use mkForAllTy. - --} - --- | A type labeled 'KnotTied' might have knot-tied tycons in it. See --- Note [Type checking recursive type and class declarations] in --- TcTyClsDecls -type KnotTied ty = ty - -{- ********************************************************************** -* * - TyCoBinder and ArgFlag -* * -********************************************************************** -} - --- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be --- dependent ('Named') or nondependent ('Anon'). They may also be visible or --- not. See Note [TyCoBinders] -data TyCoBinder - = Named TyCoVarBinder -- A type-lambda binder - | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. - -- Visibility is determined by the AnonArgFlag - deriving Data.Data - -instance Outputable TyCoBinder where - ppr (Anon af ty) = ppr af <+> ppr ty - ppr (Named (Bndr v Required)) = ppr v - ppr (Named (Bndr v Specified)) = char '@' <> ppr v - ppr (Named (Bndr v Inferred)) = braces (ppr v) - - --- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' --- in the 'Named' field. -type TyBinder = TyCoBinder - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyCoVarBinder -> VarSet -delBinderVar vars (Bndr tv _) = vars `delVarSet` tv - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyCoBinder -> Bool -isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon InvisArg _) = True -isInvisibleBinder (Anon VisArg _) = False - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyCoBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - -isNamedBinder :: TyCoBinder -> Bool -isNamedBinder (Named {}) = True -isNamedBinder (Anon {}) = False - --- | If its a named binder, is the binder a tyvar? --- Returns True for nondependent binder. --- This check that we're really returning a *Ty*Binder (as opposed to a --- coercion binder). That way, if/when we allow coercion quantification --- in more places, we'll know we missed updating some function. -isTyBinder :: TyCoBinder -> Bool -isTyBinder (Named bnd) = isTyVarBinder bnd -isTyBinder _ = True - -{- Note [TyCoBinders] -~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyCoVarBinder. But a type can be decomposed -to a telescope consisting of a [TyCoBinder] - -A TyCoBinder represents the type of binders -- that is, the type of an -argument to a Pi-type. GHC Core currently supports two different -Pi-types: - - * A non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. - - * A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty - -Both Pi-types classify terms/types that take an argument. In other -words, if `x` is either a function or a polytype, `x arg` makes sense -(for an appropriate `arg`). - - -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. - Each TyCoVarBinder - Bndr a tvis - is equipped with tvis::ArgFlag, which says whether or not arguments - for this binder should be visible (explicit) in source Haskell. - -* A TyCon contains a list of TyConBinders. Each TyConBinder - Bndr a cvis - is equipped with cvis::TyConBndrVis, which says whether or not type - and kind arguments for this TyCon should be visible (explicit) in - source Haskell. - -This table summarises the visibility rules: ---------------------------------------------------------------------------------------- -| Occurrences look like this -| GHC displays type as in Haskell source code -|-------------------------------------------------------------------------------------- -| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term -| tvis :: ArgFlag -| tvis = Inferred: f :: forall {a}. type Arg not allowed: f - f :: forall {co}. type Arg not allowed: f -| tvis = Specified: f :: forall a. type Arg optional: f or f @Int -| tvis = Required: T :: forall k -> type Arg required: T * -| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] -| -| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon -| cvis :: TyConBndrVis -| cvis = AnonTCB: T :: kind -> kind Required: T * -| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T -| T :: forall {co}. kind Arg not allowed: T -| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T -| cvis = NamedTCB Required: T :: forall k -> kind Required: T * ---------------------------------------------------------------------------------------- - -[1] In types, in the Specified case, it would make sense to allow - optional kind applications, thus (T @*), but we have not - yet implemented that - ----- In term declarations ---- - -* Inferred. Function defn, with no signature: f1 x = x - We infer f1 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because it doesn't appear in any - user-written signature for f1 - -* Specified. Function defn, with signature (implicit forall): - f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified - even though 'a' is not bound in the source code by an explicit forall - -* Specified. Function defn, with signature (explicit forall): - f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified - -* Inferred/Specified. Function signature with inferred kind polymorphism. - f4 :: a b -> Int - So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int - Here 'k' is Inferred (it's not mentioned in the type), - but 'a' and 'b' are Specified. - -* Specified. Function signature with explicit kind polymorphism - f5 :: a (b :: k) -> Int - This time 'k' is Specified, because it is mentioned explicitly, - so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int - -* Similarly pattern synonyms: - Inferred - from inferred types (e.g. no pattern type signature) - - or from inferred kind polymorphism - ----- In type declarations ---- - -* Inferred (k) - data T1 a b = MkT1 (a b) - Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * - The kind variable 'k' is Inferred, since it is not mentioned - - Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, - and Anon binders don't have a visibility flag. (Or you could think - of Anon having an implicit Required flag.) - -* Specified (k) - data T2 (a::k->*) b = MkT (a b) - Here T's kind is T :: forall (k:*). (k->*) -> k -> * - The kind variable 'k' is Specified, since it is mentioned in - the signature. - -* Required (k) - data T k (a::k->*) b = MkT (a b) - Here T's kind is T :: forall k:* -> (k->*) -> k -> * - The kind is Required, since it bound in a positional way in T's declaration - Every use of T must be explicitly applied to a kind - -* Inferred (k1), Specified (k) - data T a b (c :: k) = MkT (a b) (Proxy c) - Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * - So 'k' is Specified, because it appears explicitly, - but 'k1' is Inferred, because it does not - -Generally, in the list of TyConBinders for a TyCon, - -* Inferred arguments always come first -* Specified, Anon and Required can be mixed - -e.g. - data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... - -Here Foo's TyConBinders are - [Required 'a', Specified 'b', Anon] -and its kind prints as - Foo :: forall a -> forall b. (a -> b -> Type) -> Type - -See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls - ----- Printing ----- - - We print forall types with enough syntax to tell you their visibility - flag. But this is not source Haskell, and these types may not all - be parsable. - - Specified: a list of Specified binders is written between `forall` and `.`: - const :: forall a b. a -> b -> a - - Inferred: like Specified, but every binder is written in braces: - f :: forall {k} (a:k). S k a -> Int - - Required: binders are put between `forall` and `->`: - T :: forall k -> * - ----- Other points ----- - -* In classic Haskell, all named binders (that is, the type variables in - a polymorphic function type f :: forall a. a -> a) have been Inferred. - -* Inferred variables correspond to "generalized" variables from the - Visible Type Applications paper (ESOP'16). - -Note [No Required TyCoBinder in terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Required foralls for term variables, including pattern -synonyms and data constructors. Why? Because then an application -would need a /compulsory/ type argument (possibly without an "@"?), -thus (f Int); and we don't have concrete syntax for that. - -We could change this decision, but Required, Named TyCoBinders are rare -anyway. (Most are Anons.) - -However the type of a term can (just about) have a required quantifier; -see Note [Required quantifiers in the type of a term] in TcExpr. --} - - -{- ********************************************************************** -* * - PredType -* * -********************************************************************** -} - - --- | A type of the form @p@ of constraint kind represents a value whose type is --- the Haskell predicate @p@, where a predicate is what occurs before --- the @=>@ in a Haskell type. --- --- We use 'PredType' as documentation to mark those types that we guarantee to --- have this kind. --- --- It can be expanded into its representation, but: --- --- * The type checker must treat it as opaque --- --- * The rest of the compiler treats it as transparent --- --- Consider these examples: --- --- > f :: (Eq a) => a -> Int --- > g :: (?x :: Int -> Int) => a -> Int --- > h :: (r\l) => {r} => {l::Int | r} --- --- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -type PredType = Type - --- | A collection of 'PredType's -type ThetaType = [PredType] - -{- -(We don't support TREX records yet, but the setup is designed -to expand to allow them.) - -A Haskell qualified type, such as that for f,g,h above, is -represented using - * a FunTy for the double arrow - * with a type of kind Constraint as the function argument - -The predicate really does turn into a real extra argument to the -function. If the argument has type (p :: Constraint) then the predicate p is -represented by evidence of type p. - - -%************************************************************************ -%* * - Simple constructors -%* * -%************************************************************************ - -These functions are here so that they can be used by TysPrim, -which in turn is imported by Type --} - -mkTyVarTy :: TyVar -> Type -mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) - TyVarTy v - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -mkTyCoVarTy :: TyCoVar -> Type -mkTyCoVarTy v - | isTyVar v - = TyVarTy v - | otherwise - = CoercionTy (CoVarCo v) - -mkTyCoVarTys :: [TyCoVar] -> [Type] -mkTyCoVarTys = map mkTyCoVarTy - -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right - -mkFunTy :: AnonArgFlag -> Type -> Type -> Type -mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } - -mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type -mkVisFunTy = mkFunTy VisArg -mkInvisFunTy = mkFunTy InvisArg - --- | Make nested arrow types -mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type -mkVisFunTys tys ty = foldr mkVisFunTy ty tys -mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys - --- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder --- See Note [Unused coercion variable in ForAllTy] -mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty - --- | Wraps foralls over the type using the provided 'TyCoVar's from left to right -mkForAllTys :: [TyCoVarBinder] -> Type -> Type -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars - -mkPiTy:: TyCoBinder -> Type -> Type -mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } -mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty - -mkPiTys :: [TyCoBinder] -> Type -> Type -mkPiTys tbs ty = foldr mkPiTy ty tbs - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - -{- -%************************************************************************ -%* * - Coercions -%* * -%************************************************************************ --} - --- | A 'Coercion' is concrete evidence of the equality/convertibility --- of two types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -data Coercion - -- Each constructor has a "role signature", indicating the way roles are - -- propagated through coercions. - -- - P, N, and R stand for coercions of the given role - -- - e stands for a coercion of a specific unknown role - -- (think "role polymorphism") - -- - "e" stands for an explicit role parameter indicating role e. - -- - _ stands for a parameter that is not a Role or Coercion. - - -- These ones mirror the shape of types - = -- Refl :: _ -> N - Refl Type -- See Note [Refl invariant] - -- Invariant: applications of (Refl T) to a bunch of identity coercions - -- always show up as Refl. - -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). - - -- Applications of (Refl T) to some coercions, at least one of - -- which is NOT the identity, show up as TyConAppCo. - -- (They may not be fully saturated however.) - -- ConAppCo coercions (like all coercions other than Refl) - -- are NEVER the identity. - - -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) - - -- GRefl :: "e" -> _ -> Maybe N -> e - -- See Note [Generalized reflexive coercion] - | GRefl Role Type MCoercionN -- See Note [Refl invariant] - -- Use (Refl ty), not (GRefl Nominal ty MRefl) - -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) - - -- These ones simply lift the correspondingly-named - -- Type constructors into Coercions - - -- TyConAppCo :: "e" -> _ -> ?? -> e - -- See Note [TyConAppCo roles] - | TyConAppCo Role TyCon [Coercion] -- lift TyConApp - -- The TyCon is never a synonym; - -- we expand synonyms eagerly - -- But it can be a type function - - | AppCo Coercion CoercionN -- lift AppTy - -- AppCo :: e -> N -> e - - -- See Note [Forall coercions] - | ForAllCo TyCoVar KindCoercion Coercion - -- ForAllCo :: _ -> N -> e -> e - - | FunCo Role Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> e -> e -> e - -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? - -- Because the AnonArgFlag has no impact on Core; it is only - -- there to guide implicit instantiation of Haskell source - -- types, and that is irrelevant for coercions, which are - -- Core-only. - - -- These are special - | CoVarCo CoVar -- :: _ -> (N or R) - -- result role depends on the tycon of the variable's type - - -- AxiomInstCo :: e -> _ -> ?? -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. - -- See [Coercion axioms applied to coercions] - -- The roles of the argument coercions are determined - -- by the cab_roles field of the relevant branch of the CoAxiom - - | AxiomRuleCo CoAxiomRule [Coercion] - -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule - -- The number coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - - | UnivCo UnivCoProvenance Role Type Type - -- :: _ -> "e" -> _ -> _ -> e - - | SymCo Coercion -- :: e -> e - | TransCo Coercion Coercion -- :: e -> e -> e - - | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- Using NthCo on a ForAllCo gives an N coercion always - -- See Note [NthCo and newtypes] - -- - -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) - -- That is: the role of the entire coercion is redundantly cached here. - -- See Note [NthCo Cached Roles] - - | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) - -- :: _ -> N -> N - | InstCo Coercion CoercionN - -- :: e -> N -> e - -- See Note [InstCo roles] - - -- Extract a kind coercion from a (heterogeneous) type coercion - -- NB: all kind coercions are Nominal - | KindCo Coercion - -- :: e -> N - - | SubCo CoercionN -- Turns a ~N into a ~R - -- :: N -> R - - | HoleCo CoercionHole -- ^ See Note [Coercion holes] - -- Only present during typechecking - deriving Data.Data - -type CoercionN = Coercion -- always nominal -type CoercionR = Coercion -- always representational -type CoercionP = Coercion -- always phantom -type KindCoercion = CoercionN -- always nominal - -instance Outputable Coercion where - ppr = pprCo - --- | A semantically more meaningful type to represent what may or may not be a --- useful 'Coercion'. -data MCoercion - = MRefl - -- A trivial Reflexivity coercion - | MCo Coercion - -- Other coercions - deriving Data.Data -type MCoercionR = MCoercion -type MCoercionN = MCoercion - -instance Outputable MCoercion where - ppr MRefl = text "MRefl" - ppr (MCo co) = text "MCo" <+> ppr co - -{- -Note [Refl invariant] -~~~~~~~~~~~~~~~~~~~~~ -Invariant 1: - -Coercions have the following invariant - Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. - -You might think that a consequences is: - Every identity coercions has Refl at the root - -But that's not quite true because of coercion variables. Consider - g where g :: Int~Int - Left h where h :: Maybe Int ~ Maybe Int -etc. So the consequence is only true of coercions that -have no coercion variables. - -Note [Generalized reflexive coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GRefl is a generalized reflexive coercion (see #15192). It wraps a kind -coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing -rules for GRefl: - - ty : k1 - ------------------------------------ - GRefl r ty MRefl: ty ~r ty - - ty : k1 co :: k1 ~ k2 - ------------------------------------ - GRefl r ty (MCo co) : ty ~r ty |> co - -Consider we have - - g1 :: s ~r t - s :: k1 - g2 :: k1 ~ k2 - -and we want to construct a coercions co which has type - - (s |> g2) ~r t - -We can define - - co = Sym (GRefl r s g2) ; g1 - -It is easy to see that - - Refl == GRefl Nominal ty MRefl :: ty ~n ty - -A nominal reflexive coercion is quite common, so we keep the special form Refl to -save allocation. - -Note [Coercion axioms applied to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The reason coercion axioms can be applied to coercions and not just -types is to allow for better optimization. There are some cases where -we need to be able to "push transitivity inside" an axiom in order to -expose further opportunities for optimization. - -For example, suppose we have - - C a : t[a] ~ F a - g : b ~ c - -and we want to optimize - - sym (C b) ; t[g] ; C c - -which has the kind - - F b ~ F c - -(stopping through t[b] and t[c] along the way). - -We'd like to optimize this to just F g -- but how? The key is -that we need to allow axioms to be instantiated by *coercions*, -not just by types. Then we can (in certain cases) push -transitivity inside the axiom instantiations, and then react -opposite-polarity instantiations of the same axiom. In this -case, e.g., we match t[g] against the LHS of (C c)'s kind, to -obtain the substitution a |-> g (note this operation is sort -of the dual of lifting!) and hence end up with - - C g : t[b] ~ F c - -which indeed has the same kind as t[g] ; C c. - -Now we have - - sym (C b) ; C g - -which can be optimized to F g. - -Note [CoAxiom index] -~~~~~~~~~~~~~~~~~~~~ -A CoAxiom has 1 or more branches. Each branch has contains a list -of the free type variables in that branch, the LHS type patterns, -and the RHS type for that branch. When we apply an axiom to a list -of coercions, we must choose which branch of the axiom we wish to -use, as the different branches may have different numbers of free -type variables. (The number of type patterns is always the same -among branches, but that doesn't quite concern us here.) - -The Int in the AxiomInstCo constructor is the 0-indexed number -of the chosen branch. - -Note [Forall coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -Constructing coercions between forall-types can be a bit tricky, -because the kinds of the bound tyvars can be different. - -The typing rule is: - - - kind_co : k1 ~ k2 - tv1:k1 |- co : t1 ~ t2 - ------------------------------------------------------------------- - ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ - all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) - -First, the TyCoVar stored in a ForAllCo is really an optimisation: this field -should be a Name, as its kind is redundant. Thinking of the field as a Name -is helpful in understanding what a ForAllCo means. -The kind of TyCoVar always matches the left-hand kind of the coercion. - -The idea is that kind_co gives the two kinds of the tyvar. See how, in the -conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. - -Of course, a type variable can't have different kinds at the same time. So, -we arbitrarily prefer the first kind when using tv1 in the inner coercion -co, which shows that t1 equals t2. - -The last wrinkle is that we need to fix the kinds in the conclusion. In -t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of -the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with -(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it -mentions the same name with different kinds, but it *is* well-kinded, noting -that `(tv1:k2) |> sym kind_co` has kind k1. - -This all really would work storing just a Name in the ForAllCo. But we can't -add Names to, e.g., VarSets, and there generally is just an impedance mismatch -in a bunch of places. So we use tv1. When we need tv2, we can use -setTyVarKind. - -Note [Predicate coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: a~b -How can we coerce between types - ([c]~a) => [a] -> c -and - ([c]~b) => [b] -> c -where the equality predicate *itself* differs? - -Answer: we simply treat (~) as an ordinary type constructor, so these -types really look like - - ((~) [c] a) -> [a] -> c - ((~) [c] b) -> [b] -> c - -So the coercion between the two is obviously - - ((~) [c] g) -> [g] -> c - -Another way to see this to say that we simply collapse predicates to -their representation type (see Type.coreView and Type.predTypeRep). - -This collapse is done by mkPredCo; there is no PredCo constructor -in Coercion. This is important because we need Nth to work on -predicates too: - Nth 1 ((~) [c] g) = g -See Simplify.simplCoercionF, which generates such selections. - -Note [Roles] -~~~~~~~~~~~~ -Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated -in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see -https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation - -Here is one way to phrase the problem: - -Given: -newtype Age = MkAge Int -type family F x -type instance F Age = Bool -type instance F Int = Char - -This compiles down to: -axAge :: Age ~ Int -axF1 :: F Age ~ Bool -axF2 :: F Int ~ Char - -Then, we can make: -(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char - -Yikes! - -The solution is _roles_, as articulated in "Generative Type Abstraction and -Type-level Computation" (POPL 2010), available at -http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf - -The specification for roles has evolved somewhat since that paper. For the -current full details, see the documentation in docs/core-spec. Here are some -highlights. - -We label every equality with a notion of type equivalence, of which there are -three options: Nominal, Representational, and Phantom. A ground type is -nominally equivalent only with itself. A newtype (which is considered a ground -type in Haskell) is representationally equivalent to its representation. -Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" -to denote the equivalences. - -The axioms above would be: -axAge :: Age ~R Int -axF1 :: F Age ~N Bool -axF2 :: F Age ~N Char - -Then, because transitivity applies only to coercions proving the same notion -of equivalence, the above construction is impossible. - -However, there is still an escape hatch: we know that any two types that are -nominally equivalent are representationally equivalent as well. This is what -the form SubCo proves -- it "demotes" a nominal equivalence into a -representational equivalence. So, it would seem the following is possible: - -sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG - -What saves us here is that the arguments to a type function F, lifted into a -coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and -we are safe. - -Roles are attached to parameters to TyCons. When lifting a TyCon into a -coercion (through TyConAppCo), we need to ensure that the arguments to the -TyCon respect their roles. For example: - -data T a b = MkT a (F b) - -If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know -that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because -the type function F branches on b's *name*, not representation. So, we say -that 'a' has role Representational and 'b' has role Nominal. The third role, -Phantom, is for parameters not used in the type's definition. Given the -following definition - -data Q a = MkQ Int - -the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we -can construct the coercion Bool ~P Char (using UnivCo). - -See the paper cited above for more examples and information. - -Note [TyConAppCo roles] -~~~~~~~~~~~~~~~~~~~~~~~ -The TyConAppCo constructor has a role parameter, indicating the role at -which the coercion proves equality. The choice of this parameter affects -the required roles of the arguments of the TyConAppCo. To help explain -it, assume the following definition: - - type instance F Int = Bool -- Axiom axF : F Int ~N Bool - newtype Age = MkAge Int -- Axiom axAge : Age ~R Int - data Foo a = MkFoo a -- Role on Foo's parameter is Representational - -TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool - For (TyConAppCo Nominal) all arguments must have role Nominal. Why? - So that Foo Age ~N Foo Int does *not* hold. - -TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool -TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int - For (TyConAppCo Representational), all arguments must have the roles - corresponding to the result of tyConRoles on the TyCon. This is the - whole point of having roles on the TyCon to begin with. So, we can - have Foo Age ~R Foo Int, if Foo's parameter has role R. - - If a Representational TyConAppCo is over-saturated (which is otherwise fine), - the spill-over arguments must all be at Nominal. This corresponds to the - behavior for AppCo. - -TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool - All arguments must have role Phantom. This one isn't strictly - necessary for soundness, but this choice removes ambiguity. - -The rules here dictate the roles of the parameters to mkTyConAppCo -(should be checked by Lint). - -Note [NthCo and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype N a = MkN Int - type role N representational - -This yields axiom - - NTCo:N :: forall a. N a ~R Int - -We can then build - - co :: forall a b. N a ~R N b - co = NTCo:N a ; sym (NTCo:N b) - -for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: - - NthCo r 0 co :: forall a b. a ~R b - -Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. - -This is not just some corner case discovered by a segfault somewhere; -it was discovered in the proof of soundness of roles and described -in the "Safe Coercions" paper (ICFP '14). - -Note [NthCo Cached Roles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we cache the role of NthCo in the NthCo constructor? -Because computing role(Nth i co) involves figuring out that - - co :: T tys1 ~ T tys2 - -using coercionKind, and finding (coercionRole co), and then looking -at the tyConRoles of T. Avoiding bad asymptotic behaviour here means -we have to compute the kind and role of a coercion simultaneously, -which makes the code complicated and inefficient. - -This only happens for NthCo. Caching the role solves the problem, and -allows coercionKind and coercionRole to be simple. - -See #11735 - -Note [InstCo roles] -~~~~~~~~~~~~~~~~~~~ -Here is (essentially) the typing rule for InstCo: - -g :: (forall a. t1) ~r (forall a. t2) -w :: s1 ~N s2 -------------------------------- InstCo -InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) - -Note that the Coercion w *must* be nominal. This is necessary -because the variable a might be used in a "nominal position" -(that is, a place where role inference would require a nominal -role) in t1 or t2. If we allowed w to be representational, we -could get bogus equalities. - -A more nuanced treatment might be able to relax this condition -somewhat, by checking if t1 and/or t2 use their bound variables -in nominal ways. If not, having w be representational is OK. - - -%************************************************************************ -%* * - UnivCoProvenance -%* * -%************************************************************************ - -A UnivCo is a coercion whose proof does not directly express its role -and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). - -The different kinds of UnivCo are described by UnivCoProvenance. Really -each is entirely separate, but they all share the need to represent their -role and kind, which is done in the UnivCo constructor. - --} - --- | For simplicity, we have just one UnivCo that represents a coercion from --- some type to some other type, with (in general) no restrictions on the --- type. The UnivCoProvenance specifies more exactly what the coercion really --- is and why a program should (or shouldn't!) trust the coercion. --- It is reasonable to consider each constructor of 'UnivCoProvenance' --- as a totally independent coercion form; their only commonality is --- that they don't tell you what types they coercion between. (That info --- is in the 'UnivCo' constructor of 'Coercion'. -data UnivCoProvenance - = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom - -- roled coercions - - | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are - -- considered equivalent. See Note [ProofIrrelProv]. - -- Can be used in Nominal or Representational coercions - - | PluginProv String -- ^ From a plugin, which asserts that this coercion - -- is sound. The string is for the use of the plugin. - - deriving Data.Data - -instance Outputable UnivCoProvenance where - ppr (PhantomProv _) = text "(phantom)" - ppr (ProofIrrelProv _) = text "(proof irrel.)" - ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - --- | A coercion to be filled in by the type-checker. See Note [Coercion holes] -data CoercionHole - = CoercionHole { ch_co_var :: CoVar - -- See Note [CoercionHoles and coercion free variables] - - , ch_ref :: IORef (Maybe Coercion) - } - -coHoleCoVar :: CoercionHole -> CoVar -coHoleCoVar = ch_co_var - -setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole -setCoHoleCoVar h cv = h { ch_co_var = cv } - -instance Data.Data CoercionHole where - -- don't traverse? - toConstr _ = abstractConstr "CoercionHole" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoercionHole" - -instance Outputable CoercionHole where - ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) - - -{- Note [Phantom coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = T1 | T2 -Then we have - T s ~R T t -for any old s,t. The witness for this is (TyConAppCo T Rep co), -where (co :: s ~P t) is a phantom coercion built with PhantomProv. -The role of the UnivCo is always Phantom. The Coercion stored is the -(nominal) kind coercion between the types - kind(s) ~N kind (t) - -Note [Coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~ -During typechecking, constraint solving for type classes works by - - Generate an evidence Id, d7 :: Num a - - Wrap it in a Wanted constraint, [W] d7 :: Num a - - Use the evidence Id where the evidence is needed - - Solve the constraint later - - When solved, add an enclosing let-binding let d7 = .... in .... - which actually binds d7 to the (Num a) evidence - -For equality constraints we use a different strategy. See Note [The -equality types story] in TysPrim for background on equality constraints. - - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just - like type classes above. (Indeed, boxed equality constraints *are* classes.) - - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) - we use a different plan - -For unboxed equalities: - - Generate a CoercionHole, a mutable variable just like a unification - variable - - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest - - Use the CoercionHole in a Coercion, via HoleCo - - Solve the constraint later - - When solved, fill in the CoercionHole by side effect, instead of - doing the let-binding thing - -The main reason for all this is that there may be no good place to let-bind -the evidence for unboxed equalities: - - - We emit constraints for kind coercions, to be used to cast a - type's kind. These coercions then must be used in types. Because - they might appear in a top-level type, there is no place to bind - these (unlifted) coercions in the usual way. - - - A coercion for (forall a. t1) ~ (forall a. t2) will look like - forall a. (coercion for t1~t2) - But the coercion for (t1~t2) may mention 'a', and we don't have - let-bindings within coercions. We could add them, but coercion - holes are easier. - - - Moreover, nothing is lost from the lack of let-bindings. For - dictionaries want to achieve sharing to avoid recomoputing the - dictionary. But coercions are entirely erased, so there's little - benefit to sharing. Indeed, even if we had a let-binding, we - always inline types and coercions at every use site and drop the - binding. - -Other notes about HoleCo: - - * INVARIANT: CoercionHole and HoleCo are used only during type checking, - and should never appear in Core. Just like unification variables; a Type - can contain a TcTyVar, but only during type checking. If, one day, we - use type-level information to separate out forms that can appear during - type-checking vs forms that can appear in core proper, holes in Core will - be ruled out. - - * See Note [CoercionHoles and coercion free variables] - - * Coercion holes can be compared for equality like other coercions: - by looking at the types coerced. - - -Note [CoercionHoles and coercion free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why does a CoercionHole contain a CoVar, as well as reference to -fill in? Because we want to treat that CoVar as a free variable of -the coercion. See #14584, and Note [What prevents a -constraint from floating] in TcSimplify, item (4): - - forall k. [W] co1 :: t1 ~# t2 |> co2 - [W] co2 :: k ~# * - -Here co2 is a CoercionHole. But we /must/ know that it is free in -co1, because that's all that stops it floating outside the -implication. - - -Note [ProofIrrelProv] -~~~~~~~~~~~~~~~~~~~~~ -A ProofIrrelProv is a coercion between coercions. For example: - - data G a where - MkG :: G Bool - -In core, we get - - G :: * -> * - MkG :: forall (a :: *). (a ~ Bool) -> G a - -Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want -a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be - - TyConAppCo Nominal MkG [co3, co4] - where - co3 :: co1 ~ co2 - co4 :: a1 ~ a2 - -Note that - co1 :: a1 ~ Bool - co2 :: a2 ~ Bool - -Here, - co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) - where - co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) - co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] --} - - -{- ********************************************************************* -* * - foldType and foldCoercion -* * -********************************************************************* -} - -{- Note [foldType] -~~~~~~~~~~~~~~~~~~ -foldType is a bit more powerful than perhaps it looks: - -* You can fold with an accumulating parameter, via - TyCoFolder env (Endo a) - Recall newtype Endo a = Endo (a->a) - -* You can fold monadically with a monad M, via - TyCoFolder env (M a) - provided you have - instance .. => Monoid (M a) - -Note [mapType vs foldType] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We define foldType here, but mapType in module Type. Why? - -* foldType is used in TyCoFVs for finding free variables. - It's a very simple function that analyses a type, - but does not construct one. - -* mapType constructs new types, and so it needs to call - the "smart constructors", mkAppTy, mkCastTy, and so on. - These are sophisticated functions, and can't be defined - here in TyCoRep. - -Note [Specialising foldType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inline foldType at every call site (there are not many), so that it -becomes specialised for the particular monoid *and* TyCoFolder at -that site. This is just for efficiency, but walking over types is -done a *lot* in GHC, so worth optimising. - -We were worried that - TyCoFolder env (Endo a) -might not eta-expand. Recall newtype Endo a = Endo (a->a). - -In particular, given - fvs :: Type -> TyCoVarSet - fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet - - tcf :: TyCoFolder enf (Endo a) - tcf = TyCoFolder { tcf_tyvar = do_tv, ... } - where - do_tvs is tv = Endo do_it - where - do_it acc | tv `elemVarSet` is = acc - | tv `elemVarSet` acc = acc - | otherwise = acc `extendVarSet` tv - - -we want to end up with - fvs ty = go emptyVarSet ty emptyVarSet - where - go env (TyVarTy tv) acc = acc `extendVarSet` tv - ..etc.. - -And indeed this happens. - - Selections from 'tcf' are done at compile time - - 'go' is nicely eta-expanded. - -We were also worried about - deep_fvs :: Type -> TyCoVarSet - deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet - - deep_tcf :: TyCoFolder enf (Endo a) - deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... } - where - do_tvs is tv = Endo do_it - where - do_it acc | tv `elemVarSet` is = acc - | tv `elemVarSet` acc = acc - | otherwise = deep_fvs (varType tv) - `unionVarSet` acc - `extendVarSet` tv - -Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf. -But, amazingly, we get good code here too. GHC is careful not to makr -TyCoFolder data constructor for deep_tcf as a loop breaker, so the -record selections still cancel. And eta expansion still happens too. --} - -data TyCoFolder env a - = TyCoFolder - { tcf_view :: Type -> Maybe Type -- Optional "view" function - -- E.g. expand synonyms - , tcf_tyvar :: env -> TyVar -> a - , tcf_covar :: env -> CoVar -> a - , tcf_hole :: env -> CoercionHole -> a - -- ^ What to do with coercion holes. - -- See Note [Coercion holes] in TyCoRep. - - , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env - -- ^ The returned env is used in the extended scope - } - -{-# INLINE foldTyCo #-} -- See Note [Specialising foldType] -foldTyCo :: Monoid a => TyCoFolder env a -> env - -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) -foldTyCo (TyCoFolder { tcf_view = view - , tcf_tyvar = tyvar - , tcf_tycobinder = tycobinder - , tcf_covar = covar - , tcf_hole = cohole }) env - = (go_ty env, go_tys env, go_co env, go_cos env) - where - go_ty env ty | Just ty' <- view ty = go_ty env ty' - go_ty env (TyVarTy tv) = tyvar env tv - go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2 - go_ty _ (LitTy {}) = mempty - go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co - go_ty env (CoercionTy co) = go_co env co - go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res - go_ty env (TyConApp _ tys) = go_tys env tys - go_ty env (ForAllTy (Bndr tv vis) inner) - = let !env' = tycobinder env tv vis -- Avoid building a thunk here - in go_ty env (varType tv) `mappend` go_ty env' inner - - -- Explicit recursion becuase using foldr builds a local - -- loop (with env free) and I'm not confident it'll be - -- lambda lifted in the end - go_tys _ [] = mempty - go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts - - go_cos _ [] = mempty - go_cos env (c:cs) = go_co env c `mappend` go_cos env cs - - go_co env (Refl ty) = go_ty env ty - go_co env (GRefl _ ty MRefl) = go_ty env ty - go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co - go_co env (TyConAppCo _ _ args) = go_cos env args - go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (FunCo _ c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (CoVarCo cv) = covar env cv - go_co env (AxiomInstCo _ _ args) = go_cos env args - go_co env (HoleCo hole) = cohole env hole - go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 - `mappend` go_ty env t2 - go_co env (SymCo co) = go_co env co - go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (AxiomRuleCo _ cos) = go_cos env cos - go_co env (NthCo _ _ co) = go_co env co - go_co env (LRCo _ co) = go_co env co - go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg - go_co env (KindCo co) = go_co env co - go_co env (SubCo co) = go_co env co - go_co env (ForAllCo tv kind_co co) - = go_co env kind_co `mappend` go_ty env (varType tv) - `mappend` go_co env' co - where - env' = tycobinder env tv Inferred - - go_prov env (PhantomProv co) = go_co env co - go_prov env (ProofIrrelProv co) = go_co env co - go_prov _ (PluginProv _) = mempty - -{- ********************************************************************* -* * - typeSize, coercionSize -* * -********************************************************************* -} - --- NB: We put typeSize/coercionSize here because they are mutually --- recursive, and have the CPR property. If we have mutual --- recursion across a hi-boot file, we don't get the CPR property --- and these functions allocate a tremendous amount of rubbish. --- It's not critical (because typeSize is really only used in --- debug mode, but I tripped over an example (T5642) in which --- typeSize was one of the biggest single allocators in all of GHC. --- And it's easy to fix, so I did. - --- NB: typeSize does not respect `eqType`, in that two types that --- are `eqType` may return different sizes. This is OK, because this --- function is used only in reporting, not decision-making. - -typeSize :: Type -> Int -typeSize (LitTy {}) = 1 -typeSize (TyVarTy {}) = 1 -typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 -typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) -typeSize (CastTy ty co) = typeSize ty + coercionSize co -typeSize (CoercionTy co) = coercionSize co - -coercionSize :: Coercion -> Int -coercionSize (Refl ty) = typeSize ty -coercionSize (GRefl _ ty MRefl) = typeSize ty -coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co -coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (AppCo co arg) = coercionSize co + coercionSize arg -coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h -coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (CoVarCo _) = 1 -coercionSize (HoleCo _) = 1 -coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 -coercionSize (SymCo co) = 1 + coercionSize co -coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ _ co) = 1 + coercionSize co -coercionSize (LRCo _ co) = 1 + coercionSize co -coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg -coercionSize (KindCo co) = 1 + coercionSize co -coercionSize (SubCo co) = 1 + coercionSize co -coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) - -provSize :: UnivCoProvenance -> Int -provSize (PhantomProv co) = 1 + coercionSize co -provSize (ProofIrrelProv co) = 1 + coercionSize co -provSize (PluginProv _) = 1 diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot deleted file mode 100644 --- a/compiler/types/TyCoRep.hs-boot +++ /dev/null @@ -1,23 +0,0 @@ -module TyCoRep where - -import Data.Data ( Data ) -import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) - -data Type -data TyThing -data Coercion -data UnivCoProvenance -data TyLit -data TyCoBinder -data MCoercion - -type PredType = Type -type Kind = Type -type ThetaType = [PredType] -type CoercionN = Coercion -type MCoercionN = MCoercion - -mkFunTy :: AnonArgFlag -> Type -> Type -> Type -mkForAllTy :: Var -> ArgFlag -> Type -> Type - -instance Data Type -- To support Data instances in CoAxiom diff --git a/compiler/types/TyCoSubst.hs b/compiler/types/TyCoSubst.hs deleted file mode 100644 --- a/compiler/types/TyCoSubst.hs +++ /dev/null @@ -1,1030 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 -Type and Coercion - friends' interface --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Substitution into types and coercions. -module TyCoSubst - ( - -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, mkCvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendTCvSubstWithClone, - extendCvSubst, extendCvSubstWithClone, - extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - unionTCvSubst, zipTyEnv, zipCoEnv, - zipTvSubst, zipCvSubst, - zipTCvSubst, - mkTvSubstPrs, - - substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, - substCoWith, - substTy, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyWithInScope, - substTys, substTheta, - lookupTyVar, - substCo, substCos, substCoVar, substCoVars, lookupCoVar, - cloneTyVarBndr, cloneTyVarBndrs, - substVarBndr, substVarBndrs, - substTyVarBndr, substTyVarBndrs, - substCoVarBndr, - substTyVar, substTyVars, substTyCoVars, - substForAllCoBndr, - substVarBndrUsing, substForAllCoBndrUsing, - checkValidSubst, isValidTCvSubst, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Type ( mkCastTy, mkAppTy, isCoercionTy ) -import {-# SOURCE #-} Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo - , mkNomReflCo, mkSubCo, mkSymCo - , mkFunCo, mkForAllCo, mkUnivCo - , mkAxiomInstCo, mkAppCo, mkGReflCo - , mkInstCo, mkLRCo, mkTyConAppCo - , mkCoercionType - , coercionKind, coercionLKind, coVarKindsTypesRole ) - -import TyCoRep -import TyCoFVs -import TyCoPpr - -import Var -import VarSet -import VarEnv - -import Pair -import Util -import UniqSupply -import Unique -import UniqFM -import UniqSet -import Outputable - -import Data.List (mapAccumL) - -{- -%************************************************************************ -%* * - Substitutions - Data type defined here to avoid unnecessary mutual recursion -%* * -%************************************************************************ --} - --- | Type & coercion substitution --- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Substitutions apply only once] - -- and Note [Extending the TvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] - --- | A substitution of 'Type's for 'TyVar's --- and 'Kind's for 'KindVar's -type TvSubstEnv = TyVarEnv Type - -- NB: A TvSubstEnv is used - -- both inside a TCvSubst (with the apply-once invariant - -- discussed in Note [Substitutions apply only once], - -- and also independently in the middle of matching, - -- and unification (see Types.Unify). - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - --- | A substitution of 'Coercion's for 'CoVar's -type CvSubstEnv = CoVarEnv Coercion - -{- Note [The substitution invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When calling (substTy subst ty) it should be the case that -the in-scope set in the substitution is a superset of both: - - (SIa) The free vars of the range of the substitution - (SIb) The free vars of ty minus the domain of the substitution - -The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) - -* Reason for (SIa). Consider - substTy [a :-> Maybe b] (forall b. b->a) - we must rename the forall b, to get - forall b2. b2 -> Maybe b - Making 'b' part of the in-scope set forces this renaming to - take place. - -* Reason for (SIb). Consider - substTy [a :-> Maybe b] (forall b. (a,b,x)) - Then if we use the in-scope set {b}, satisfying (SIa), there is - a danger we will rename the forall'd variable to 'x' by mistake, - getting this: - forall x. (Maybe b, x, x) - Breaking (SIb) caused the bug from #11371. - -Note: if the free vars of the range of the substitution are freshly created, -then the problems of (SIa) can't happen, and so it would be sound to -ignore (SIa). - -Note [Substitutions apply only once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use TCvSubsts to instantiate things, and we might instantiate - forall a b. ty -with the types - [a, b], or [b, a]. -So the substitution might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substitution that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - ******************************************************** - *** So a substitution must be applied precisely once *** - ******************************************************** - -A TCvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubstEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tcvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the subst envs are empty: -if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) -holds --- then (substTy subst ty) does nothing. - -For example, consider: - (/\a. /\b:(a~Int). ...b..) Int -We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's kind does change - -This invariant has several crucial consequences: - -* In substVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - -Note [Substituting types and coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types and coercions are mutually recursive, and either may have variables -"belonging" to the other. Thus, every time we wish to substitute in a -type, we may also need to substitute in a coercion, and vice versa. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. - -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with -CoercionTy. --} - -emptyTvSubstEnv :: TvSubstEnv -emptyTvSubstEnv = emptyVarEnv - -emptyCvSubstEnv :: CvSubstEnv -emptyCvSubstEnv = emptyVarEnv - -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - --- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 - where - is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) - -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv - -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv - -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv - -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv - -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv - -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified covar subst and empty tyvar subst -mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv - -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env - -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env - -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope - --- | Returns the free variables of the types in the range of a substitution as --- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs - where - tenvFVs = shallowTyCoVarsOfTyVarEnv tenv - cenvFVs = shallowTyCoVarsOfCoVarEnv cenv - -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v (TCvSubst _ tenv cenv) - | isTyVar v - = not (v `elemVarEnv` tenv) - | otherwise - = not (v `elemVarEnv` cenv) - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv - -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv - -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv - -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv - -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv - -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv - -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst -extendTCvSubst subst v ty - | isTyVar v - = extendTvSubst subst v ty - | CoercionTy co <- ty - = extendCvSubst subst v co - | otherwise - = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) - -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst -extendTCvSubstWithClone subst tcv - | isTyVar tcv = extendTvSubstWithClone subst tcv - | otherwise = extendCvSubstWithClone subst tcv - -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv - -extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst -extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty - = ASSERT( isTyVar v ) - extendTvSubstAndInScope subst v ty -extendTvSubstBinderAndInScope subst (Anon {}) _ - = subst - -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst --- Adds a new tv -> tv mapping, /and/ extends the in-scope set -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - (extendVarEnv tenv tv (mkTyVarTy tv')) - cenv - where - new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' - -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) - -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - tenv - (extendVarEnv cenv cv (mkCoVarCo cv')) - where - new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' - -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst --- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) - (extendVarEnv tenv tv ty) - cenv - -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys - -extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTCvSubstList subst tvs tys - = foldl2 extendTCvSubst subst tvs tys - -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst --- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) - && not (cenv1 `intersectsVarEnv` cenv2) ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst -zipTvSubst tvs tys - = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv - where - tenv = zipTyEnv tvs tys - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No TyVars, please! -zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst -zipCvSubst cvs cos - = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv - where - cenv = zipCoEnv cvs cos - -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst -zipTCvSubst tcvs tys - = zip_tcvsubst tcvs tys $ - mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys - where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst - zip_tcvsubst (tv:tvs) (ty:tys) subst - = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) - zip_tcvsubst [] [] subst = subst -- empty case - zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" - (ppr tcvs <+> ppr tys) - --- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs prs = - ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) - mkTvSubst in_scope tenv - where tenv = mkVarEnv prs - in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs - onlyTyVarsAndNoCoercionTy = - and [ isTyVar tv && not (isCoercionTy ty) - | (tv, ty) <- prs ] - -zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv -zipTyEnv tyvars tys - | debugIsOn - , not (all isTyVar tyvars) - = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) - | otherwise - = ASSERT( all (not . isCoercionTy) tys ) - mkVarEnv (zipEqual "zipTyEnv" tyvars tys) - -- There used to be a special case for when - -- ty == TyVarTy tv - -- (a not-uncommon case) in which case the substitution was dropped. - -- But the type-tidier changes the print-name of a type variable without - -- changing the unique, and that led to a bug. Why? Pre-tidying, we had - -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. - -- And it happened that t was the type variable of the class. Post-tiding, - -- it got turned into {Foo t2}. The ext-core printer expanded this using - -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, - -- and so generated a rep type mentioning t not t2. - -- - -- Simplest fix is to nuke the "optimisation" - -zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv -zipCoEnv cvs cos - | debugIsOn - , not (all isCoVar cvs) - = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) - | otherwise - = mkVarEnv (zipEqual "zipCoEnv" cvs cos) - -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] - -{- -%************************************************************************ -%* * - Performing type or kind substitutions -%* * -%************************************************************************ - -Note [Sym and ForAllCo] -~~~~~~~~~~~~~~~~~~~~~~~ -In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, -how do we push sym into a ForAllCo? It's a little ugly. - -Here is the typing rule: - -h : k1 ~# k2 -(tv : k1) |- g : ty1 ~# ty2 ----------------------------- -ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# - (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) - -Here is what we want: - -ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# - (ForAllTy (tv : k1) ty1) - - -Because the kinds of the type variables to the right of the colon are the kinds -coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). - -Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want - -ForAllCo tv h' g' : - (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# - (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) - -We thus see that we want - -g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] - -and thus g' = sym (g[tv |-> tv |> h']). - -Putting it all together, we get this: - -sym (ForAllCo tv h g) -==> -ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) - -Note [Substituting in a coercion hole] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It seems highly suspicious to be substituting in a coercion that still -has coercion holes. Yet, this can happen in a situation like this: - - f :: forall k. k :~: Type -> () - f Refl = let x :: forall (a :: k). [a] -> ... - x = ... - -When we check x's type signature, we require that k ~ Type. We indeed -know this due to the Refl pattern match, but the eager unifier can't -make use of givens. So, when we're done looking at x's type, a coercion -hole will remain. Then, when we're checking x's definition, we skolemise -x's type (in order to, e.g., bring the scoped type variable `a` into scope). -This requires performing a substitution for the fresh skolem variables. - -This substitution needs to affect the kind of the coercion hole, too -- -otherwise, the kind will have an out-of-scope variable in it. More problematically -in practice (we won't actually notice the out-of-scope variable ever), skolems -in the kind might have too high a level, triggering a failure to uphold the -invariant that no free variables in a type have a higher level than the -ambient level in the type checker. In the event of having free variables in the -hole's kind, I'm pretty sure we'll always have an erroneous program, so we -don't need to worry what will happen when the hole gets filled in. After all, -a hole relating a locally-bound type variable will be unable to be solved. This -is why it's OK not to look through the IORef of a coercion hole during -substitution. - --} - --- | Type substitution, see 'zipTvSubst' -substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type --- Works only if the domain of the substitution is a --- superset of the type being substituted into -substTyWith tvs tys = {-#SCC "substTyWith" #-} - ASSERT( tvs `equalLength` tys ) - substTy (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type -substTyWithUnchecked tvs tys - = ASSERT( tvs `equalLength` tys ) - substTyUnchecked (zipTvSubst tvs tys) - --- | Substitute tyvars within a type using a known 'InScopeSet'. --- Pre-condition: the 'in_scope' set should satisfy Note [The substitution --- invariant]; specifically it should include the free vars of 'tys', --- and of 'ty' minus the domain of the subst. -substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type -substTyWithInScope in_scope tvs tys ty = - ASSERT( tvs `equalLength` tys ) - substTy (mkTvSubst in_scope tenv) ty - where tenv = zipTyEnv tvs tys - --- | Coercion substitution, see 'zipTvSubst' -substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion -substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) - substCo (zipTvSubst tvs tys) - --- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithUnchecked tvs tys - = ASSERT( tvs `equalLength` tys ) - substCoUnchecked (zipTvSubst tvs tys) - - - --- | Substitute covars within a type -substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type -substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) - --- | Type substitution, see 'zipTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) - substTys (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst' -substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] -substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) - substTys (zipCvSubst cvs cos) - --- | Substitute within a 'Type' after adding the free variables of the type --- to the in-scope set. This is useful for the case when the free variables --- aren't already in the in-scope set or easily available. --- See also Note [The substitution invariant]. -substTyAddInScope :: TCvSubst -> Type -> Type -substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty - --- | When calling `substTy` it should be the case that the in-scope set in --- the substitution is a superset of the free vars of the range of the --- substitution. --- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = - (tenvFVs `varSetInScope` in_scope) && - (cenvFVs `varSetInScope` in_scope) - where - tenvFVs = shallowTyCoVarsOfTyVarEnv tenv - cenvFVs = shallowTyCoVarsOfCoVarEnv cenv - --- | This checks if the substitution satisfies the invariant from --- Note [The substitution invariant]. -checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a - = ASSERT2( isValidTCvSubst subst, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$ - text "cenv" <+> ppr cenv $$ - text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos ) - ASSERT2( tysCosFVsInScope, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "cenv" <+> ppr cenv $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos $$ - text "needInScope" <+> ppr needInScope ) - a - where - substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv - -- It's OK to use nonDetKeysUFM here, because we only use this list to - -- remove some elements from a set - needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet` - shallowTyCoVarsOfCos cos) - `delListFromUniqSet_Directly` substDomain - tysCosFVsInScope = needInScope `varSetInScope` in_scope - - --- | Substitute within a 'Type' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTy :: HasCallStack => TCvSubst -> Type -> Type -substTy subst ty - | isEmptyTCvSubst subst = ty - | otherwise = checkValidSubst subst [ty] [] $ - subst_ty subst ty - --- | Substitute within a 'Type' disabling the sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type -substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty - | otherwise = subst_ty subst ty - --- | Substitute within several 'Type's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] -substTys subst tys - | isEmptyTCvSubst subst = tys - | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys - --- | Substitute within several 'Type's disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTysUnchecked to --- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] -substTysUnchecked subst tys - | isEmptyTCvSubst subst = tys - | otherwise = map (subst_ty subst) tys - --- | Substitute within a 'ThetaType' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType -substTheta = substTys - --- | Substitute within a 'ThetaType' disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substThetaUnchecked to --- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType -substThetaUnchecked = substTysUnchecked - - -subst_ty :: TCvSubst -> Type -> Type --- subst_ty is the main workhorse for type substitution --- --- Note that the in_scope set is poked only if we hit a forall --- so it may often never be fully computed -subst_ty subst ty - = go ty - where - go (TyVarTy tv) = substTyVar subst tv - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - go ty@(FunTy { ft_arg = arg, ft_res = res }) - = let !arg' = go arg - !res' = go res - in ty { ft_arg = arg', ft_res = res' } - go (ForAllTy (Bndr tv vis) ty) - = case substVarBndrUnchecked subst tv of - (subst', tv') -> - (ForAllTy $! ((Bndr $! tv') vis)) $! - (subst_ty subst' ty) - go (LitTy n) = LitTy $! n - go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) - go (CoercionTy co) = CoercionTy $! (subst_co subst co) - -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - case lookupVarEnv tenv tv of - Just ty -> ty - Nothing -> TyVarTy tv - -substTyVars :: TCvSubst -> [TyVar] -> [Type] -substTyVars subst = map $ substTyVar subst - -substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] -substTyCoVars subst = map $ substTyCoVar subst - -substTyCoVar :: TCvSubst -> TyCoVar -> Type -substTyCoVar subst tv - | isTyVar tv = substTyVar subst tv - | otherwise = CoercionTy $ substCoVar subst tv - -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubst] -lookupTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - lookupVarEnv tenv tv - --- | Substitute within a 'Coercion' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion -substCo subst co - | isEmptyTCvSubst subst = co - | otherwise = checkValidSubst subst [] [co] $ subst_co subst co - --- | Substitute within a 'Coercion' disabling sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion -substCoUnchecked subst co - | isEmptyTCvSubst subst = co - | otherwise = subst_co subst co - --- | Substitute within several 'Coercion's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] -substCos subst cos - | isEmptyTCvSubst subst = cos - | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos - -subst_co :: TCvSubst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = subst_ty subst - - go_mco :: MCoercion -> MCoercion - go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) - - go :: Coercion -> Coercion - go (Refl ty) = mkNomReflCo $! (go_ty ty) - go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) - go (TyConAppCo r tc args)= let args' = map go args - in args' `seqList` mkTyConAppCo r tc args' - go (AppCo co arg) = (mkAppCo $! go co) $! go arg - go (ForAllCo tv kind_co co) - = case substForAllCoBndrUnchecked subst tv kind_co of - (subst', tv', kind_co') -> - ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co - go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 - go (CoVarCo cv) = substCoVar subst cv - go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos - go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! - (go_ty t1)) $! (go_ty t2) - go (SymCo co) = mkSymCo $! (go co) - go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (NthCo r d co) = mkNthCo r d $! (go co) - go (LRCo lr co) = mkLRCo lr $! (go co) - go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg - go (KindCo co) = mkKindCo $! (go co) - go (SubCo co) = mkSubCo $! (go co) - go (AxiomRuleCo c cs) = let cs1 = map go cs - in cs1 `seqList` AxiomRuleCo c cs1 - go (HoleCo h) = HoleCo $! go_hole h - - go_prov (PhantomProv kco) = PhantomProv (go kco) - go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) - go_prov p@(PluginProv _) = p - - -- See Note [Substituting in a coercion hole] - go_hole h@(CoercionHole { ch_co_var = cv }) - = h { ch_co_var = updateVarType go_ty cv } - -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) -substForAllCoBndr subst - = substForAllCoBndrUsing False (substCo subst) subst - --- | Like 'substForAllCoBndr', but disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) -substForAllCoBndrUnchecked subst - = substForAllCoBndrUsing False (substCoUnchecked subst) subst - --- See Note [Sym and ForAllCo] -substForAllCoBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, KindCoercion) -substForAllCoBndrUsing sym sco subst old_var - | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var - | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var - -substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> KindCoercion - -> (TCvSubst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co - = ASSERT( isTyVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv - , new_var, new_kind_co ) - where - new_env | no_change && not sym = delVarEnv tenv old_var - | sym = extendVarEnv tenv old_var $ - TyVarTy new_var `CastTy` new_kind_co - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - new_ki1 = coercionLKind new_kind_co - -- We could do substitution to (tyVarKind old_var). We don't do so because - -- we already substituted new_kind_co, which contains the kind information - -- we want. We don't want to do substitution once more. Also, in most cases, - -- new_kind_co is a Refl, in which case coercionKind is really fast. - - new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) - -substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> CoVar -> KindCoercion - -> (TCvSubst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) - old_var old_kind_co - = ASSERT( isCoVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv - , new_var, new_kind_co ) - where - new_cenv | no_change && not sym = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - Pair h1 h2 = coercionKind new_kind_co - - new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type - new_var_type | sym = h2 - | otherwise = h1 - -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv - = case lookupVarEnv cenv cv of - Just co -> co - Nothing -> CoVarCo cv - -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] -substCoVars subst cvs = map (substCoVar subst) cvs - -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v - -substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndr = substTyVarBndrUsing substTy - -substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) -substTyVarBndrs = mapAccumL substTyVarBndr - -substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndr = substVarBndrUsing substTy - -substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) -substVarBndrs = mapAccumL substVarBndr - -substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndr = substCoVarBndrUsing substTy - --- | Like 'substVarBndr', but disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndrUnchecked = substVarBndrUsing substTyUnchecked - -substVarBndrUsing :: (TCvSubst -> Type -> Type) - -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndrUsing subst_fn subst v - | isTyVar v = substTyVarBndrUsing subst_fn subst v - | otherwise = substCoVarBndrUsing subst_fn subst v - --- | Substitute a tyvar in a binding position, returning an --- extended subst and a new tyvar. --- Use the supplied function to substitute in the kind -substTyVarBndrUsing - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) - ASSERT( isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) - where - new_env | no_change = delVarEnv tenv old_var - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv) - -- Assertion check that we are not capturing something in the substitution - - old_ki = tyVarKind old_var - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - no_change = no_kind_change && (new_var == old_var) - -- no_change means that the new_var is identical in - -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubst] - -- - -- In that case we don't need to extend the substitution - -- to map old to new. But instead we must zap any - -- current substitution for the variable. For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - - new_var | no_kind_change = uniqAway in_scope old_var - | otherwise = uniqAway in_scope $ - setTyVarKind old_var (subst_fn subst old_ki) - -- The uniqAway part makes sure the new variable is not already in scope - --- | Substitute a covar in a binding position, returning an --- extended subst and a new covar. --- Use the supplied function to substitute in the kind -substCoVarBndrUsing - :: (TCvSubst -> Type -> Type) - -> TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT( isCoVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) - where - new_co = mkCoVarCo new_var - no_kind_change = noFreeVarsOfTypes [t1, t2] - no_change = new_var == old_var && no_kind_change - - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var new_co - - new_var = uniqAway in_scope subst_old_var - subst_old_var = mkCoVar (varName old_var) new_var_type - - (_, _, t1, t2, role) = coVarKindsTypesRole old_var - t1' = subst_fn subst t1 - t2' = subst_fn subst t2 - new_var_type = mkCoercionType role t1' t2' - -- It's important to do the substitution for coercions, - -- because they can have free type variables - -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq - = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') - where - old_ki = tyVarKind tv - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - - tv1 | no_kind_change = tv - | otherwise = setTyVarKind tv (substTy subst old_ki) - - tv' = setVarUnique tv1 uniq - -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) -cloneTyVarBndrs subst [] _usupply = (subst, []) -cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) - where - (uniq, usupply') = takeUniqFromSupply usupply - (subst' , tv ) = cloneTyVarBndr subst t uniq - (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' diff --git a/compiler/types/TyCoTidy.hs b/compiler/types/TyCoTidy.hs deleted file mode 100644 --- a/compiler/types/TyCoTidy.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Tidying types and coercions for printing in error messages. -module TyCoTidy - ( - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyKind, - tidyCo, tidyCos, - tidyTyCoVarBinder, tidyTyCoVarBinders - ) where - -import GhcPrelude - -import TyCoRep -import TyCoFVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) - -import Name hiding (varName) -import Var -import VarEnv -import Util (seqList) - -import Data.List (mapAccumL) - -{- -%************************************************************************ -%* * -\subsection{TidyType} -%* * -%************************************************************************ --} - --- | This tidies up a type for printing in an error message, or in --- an interface file. --- --- It doesn't change the uniques at all, just the print names. -tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyVarBndrs tidy_env tvs - = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs - -tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -tidyVarBndr tidy_env@(occ_env, subst) var - = case tidyOccName occ_env (getHelpfulOccName var) of - (occ_env', occ') -> ((occ_env', subst'), var') - where - subst' = extendVarEnv subst var var' - var' = setVarType (setVarName var name') type' - type' = tidyType tidy_env (varType var) - name' = tidyNameOcc name occ' - name = varName var - -avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv --- Seed the occ_env with clashes among the names, see --- Note [Tidying multiple names at once] in OccName -avoidNameClashes tvs (occ_env, subst) - = (avoidClashesOccEnv occ_env occs, subst) - where - occs = map getHelpfulOccName tvs - -getHelpfulOccName :: TyCoVar -> OccName --- A TcTyVar with a System Name is probably a --- unification variable; when we tidy them we give them a trailing --- "0" (or 1 etc) so that they don't take precedence for the --- un-modified name. Plus, indicating a unification variable in --- this way is a helpful clue for users -getHelpfulOccName tv - | isSystemName name, isTcTyVar tv - = mkTyVarOcc (occNameString occ ++ "0") - | otherwise - = occ - where - name = varName tv - occ = getOccName name - -tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis - -> (TidyEnv, VarBndr TyCoVar vis) -tidyTyCoVarBinder tidy_env (Bndr tv vis) - = (tidy_env', Bndr tv' vis) - where - (tidy_env', tv') = tidyVarBndr tidy_env tv - -tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] - -> (TidyEnv, [VarBndr TyCoVar vis]) -tidyTyCoVarBinders tidy_env tvbs - = mapAccumL tidyTyCoVarBinder - (avoidNameClashes (binderVars tvbs) tidy_env) tvbs - ---------------- -tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyCoVars tidy_env tyvars - = fst (tidyOpenTyCoVars tidy_env tyvars) - ---------------- -tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars - ---------------- -tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) --- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyVarBndr' -tidyOpenTyCoVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> - let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) - in tidyVarBndr env' tyvar -- Treat it as a binder - ---------------- -tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar -tidyTyCoVarOcc env@(_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> updateVarType (tidyType env) tv - Just tv' -> tv' - ---------------- -tidyTypes :: TidyEnv -> [Type] -> [Type] -tidyTypes env tys = map (tidyType env) tys - ---------------- -tidyType :: TidyEnv -> Type -> Type -tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) -tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys - in args `seqList` TyConApp tycon args -tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg - ; !res' = tidyType env res } - in ty { ft_arg = arg', ft_res = res' } -tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty - where - (tvs, vis, body_ty) = splitForAllTys' ty - (env', tvs') = tidyVarBndrs env tvs -tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) -tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) - - --- The following two functions differ from mkForAllTys and splitForAllTys in that --- they expect/preserve the ArgFlag argument. These belong to types/Type.hs, but --- how should they be named? -mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type -mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs - where - strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty - -splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) -splitForAllTys' ty = go ty [] [] - where - go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) - go ty tvs viss = (reverse tvs, reverse viss, ty) - - ---------------- --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys - = (env', tidyTypes (trimmed_occ_env, var_env) tys) - where - (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ - tyCoVarsOfTypesWellScoped tys - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the types, so that we don't gratuitously rename - -- the _bound_ variables of the types. - ---------------- -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in - (env', ty') - ---------------- --- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty - ---------------- -tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyOpenKind = tidyOpenType - -tidyKind :: TidyEnv -> Kind -> Kind -tidyKind = tidyType - ----------------- -tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co - where - go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) - - go (Refl ty) = Refl (tidyType env ty) - go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco - go (TyConAppCo r tc cos) = let args = map go cos - in args `seqList` TyConAppCo r tc args - go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) - where (envp, tvp) = tidyVarBndr env tv - -- the case above duplicates a bit of work in tidying h and the kind - -- of tv. But the alternative is to use coercionKind, which seems worse. - go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (HoleCo h) = HoleCo h - go (AxiomInstCo con ind cos) = let args = map go cos - in args `seqList` AxiomInstCo con ind args - go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! - tidyType env t1) $! tidyType env t2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo r d co) = NthCo r d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! go ty - go (KindCo co) = KindCo $! go co - go (SubCo co) = SubCo $! go co - go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos - in cos1 `seqList` AxiomRuleCo ax cos1 - - go_prov (PhantomProv co) = PhantomProv (go co) - go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) - go_prov p@(PluginProv _) = p - -tidyCos :: TidyEnv -> [Coercion] -> [Coercion] -tidyCos env = map (tidyCo env) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs deleted file mode 100644 --- a/compiler/types/TyCon.hs +++ /dev/null @@ -1,2807 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @TyCon@ datatype --} - -{-# LANGUAGE CPP, FlexibleInstances #-} - -module TyCon( - -- * Main TyCon data types - TyCon, - AlgTyConRhs(..), visibleDataCons, - AlgTyConFlav(..), isNoParent, - FamTyConFlav(..), Role(..), Injectivity(..), - RuntimeRepInfo(..), TyConFlavour(..), - - -- * TyConBinder - TyConBinder, TyConBndrVis(..), TyConTyCoBinder, - mkNamedTyConBinder, mkNamedTyConBinders, - mkRequiredTyConBinder, - mkAnonTyConBinder, mkAnonTyConBinders, - tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, - - -- ** Field labels - tyConFieldLabels, lookupTyConFieldLabel, - - -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, - mkFunTyCon, - mkPrimTyCon, - mkKindTyCon, - mkLiftedPrimTyCon, - mkTupleTyCon, - mkSumTyCon, - mkDataTyConRhs, - mkSynonymTyCon, - mkFamilyTyCon, - mkPromotedDataCon, - mkTcTyCon, - noTcTyConScopedTyVars, - - -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, - isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isUnboxedSumTyCon, isPromotedTupleTyCon, - isTypeSynonymTyCon, - mustBeSaturated, - isPromotedDataCon, isPromotedDataCon_maybe, - isKindTyCon, isLiftedTypeKindTyConName, - isTauTyCon, isFamFreeTyCon, - - isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, - isDataSumTyCon_maybe, - isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, - isFamilyTyCon, isOpenFamilyTyCon, - isTypeFamilyTyCon, isDataFamilyTyCon, - isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, - tyConInjectivityInfo, - isBuiltInSynFamTyCon_maybe, - isUnliftedTyCon, - isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, - isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, - isImplicitTyCon, - isTyConWithSrcDataCons, - isTcTyCon, setTcTyConKind, - isTcLevPoly, - - -- ** Extracting information out of TyCons - tyConName, - tyConSkolem, - tyConKind, - tyConUnique, - tyConTyVars, tyConVisibleTyVars, - tyConCType, tyConCType_maybe, - tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConSingleAlgDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, - tyConRoles, - tyConFlavour, - tyConTuple_maybe, tyConClass_maybe, tyConATs, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - tyConFamilyResVar_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, - famTyConFlav_maybe, famTcResVar, - algTyConRhs, - newTyConRhs, newTyConEtadArity, newTyConEtadRhs, - unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, - newTyConDataCon_maybe, - algTcFields, - tyConRuntimeRepInfo, - tyConBinders, tyConResKind, tyConTyVarBinders, - tcTyConScopedTyVars, tcTyConIsPoly, - mkTyConTagMap, - - -- ** Manipulating TyCons - expandSynTyCon_maybe, - newTyConCo, newTyConCo_maybe, - pprPromotionQuote, mkTyConKind, - - -- ** Predicated on TyConFlavours - tcFlavourIsOpen, - - -- * Runtime type representation - TyConRepName, tyConRepName_maybe, - mkPrelTyConRepName, - tyConRepModOcc, - - -- * Primitive representations of Types - PrimRep(..), PrimElemRep(..), - isVoidRep, isGcPtrRep, - primRepSizeB, - primElemRepSizeB, - primRepIsFloat, - primRepsCompatible, - primRepCompatible, - - -- * Recursion breaking - RecTcChecker, initRecTc, defaultRecTcMaxBound, - setRecTcMaxBound, checkRecTc - -) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, mkForAllTy, mkFunTy ) -import {-# SOURCE #-} TyCoPpr ( pprType ) -import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind - , vecCountTyCon, vecElemTyCon, liftedTypeKind ) -import {-# SOURCE #-} DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels - , dataConTyCon, dataConFullSig - , isUnboxedSumCon ) - -import Binary -import Var -import VarSet -import Class -import BasicTypes -import GHC.Driver.Session -import ForeignCall -import Name -import NameEnv -import CoAxiom -import PrelNames -import Maybes -import Outputable -import FastStringEnv -import FieldLabel -import Constants -import Util -import Unique( tyConRepNameUnique, dataConTyRepNameUnique ) -import UniqSet -import Module - -import qualified Data.Data as Data - -{- ------------------------------------------------ - Notes about type families ------------------------------------------------ - -Note [Type synonym families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Type synonym families, also known as "type functions", map directly - onto the type functions in FC: - - type family F a :: * - type instance F Int = Bool - ..etc... - -* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon - -* From the user's point of view (F Int) and Bool are simply - equivalent types. - -* A Haskell 98 type synonym is a degenerate form of a type synonym - family. - -* Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! - -* Translation of type family decl: - type family F a :: * - translates to - a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon - - type family G a :: * where - G Int = Bool - G Bool = Char - G a = () - translates to - a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the - appropriate CoAxiom representing the equations - -We also support injective type families -- see Note [Injective type families] - -Note [Data type families] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Wrappers for data instance tycons] in MkId.hs - -* Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool - - Here T is the "family TyCon". - -* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon - -* The user does not see any "equivalent types" as he did with type - synonym families. He just sees constructors with types - T1 :: T Int - T2 :: Bool -> T Int - -* Here's the FC version of the above declarations: - - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~R R:TInt - - Note that this is a *representational* coercion - The R:TInt is the "representation TyCons". - It has an AlgTyConFlav of - DataFamInstTyCon T [Int] ax_ti - -* The axiom ax_ti may be eta-reduced; see - Note [Eta reduction for data families] in FamInstEnv - -* Data family instances may have a different arity than the data family. - See Note [Arity of data families] in FamInstEnv - -* The data constructor T2 has a wrapper (which is what the - source-level "T2" invokes): - - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti - -* A data instance can declare a fully-fledged GADT: - - data instance T (a,b) where - X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) - - Here's the FC version of the above declaration: - - data R:TPair a b where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~R R:TPair a b - - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) - - The R:TPair are the "representation TyCons". - We have a bit of work to do, to unpick the result types of the - data instance declaration for T (a,b), to get the result type in the - representation; e.g. T (a,b) --> R:TPair a b - - The representation TyCon R:TList, has an AlgTyConFlav of - - DataFamInstTyCon T [(a,b)] ax_pr - -* Notice that T is NOT translated to a FC type function; it just - becomes a "data type" with no constructors, which can be coerced - into R:TInt, R:TPair by the axioms. These axioms - axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching - Rather like newtype, in fact - - As a result - - - T behaves just like a data type so far as decomposition is concerned - - - (T Int) is not implicitly converted to R:TInt during type inference. - Indeed the latter type is unknown to the programmer. - - - There *is* an instance for (T Int) in the type-family instance - environment, but it is only used for overlap checking - - - It's fine to have T in the LHS of a type function: - type instance F (T a) = [a] - - It was this last point that confused me! The big thing is that you - should not think of a data family T as a *type function* at all, not - even an injective one! We can't allow even injective type functions - on the LHS of a type function: - type family injective G a :: * - type instance F (G Int) = Bool - is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char - - So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. - -* The tyConTyVars of the representation tycon are the tyvars that the - user wrote in the patterns. This is important in TcDeriv, where we - bring these tyvars into scope before type-checking the deriving - clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. - -Note [Associated families and their parent class] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Associated* families are just like *non-associated* families, except -that they have a famTcParent field of (Just cls_tc), which identifies the -parent class. - -However there is an important sharing relationship between - * the tyConTyVars of the parent Class - * the tyConTyVars of the associated TyCon - - class C a b where - data T p a - type F a q b - -Here the 'a' and 'b' are shared with the 'Class'; that is, they have -the same Unique. - -This is important. In an instance declaration we expect - * all the shared variables to be instantiated the same way - * the non-shared variables of the associated type should not - be instantiated at all - - instance C [x] (Tree y) where - data T p [x] = T1 x | T2 p - type F [x] q (Tree y) = (x,y,q) - -Note [TyCon Role signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every tycon has a role signature, assigning a role to each of the tyConTyVars -(or of equal length to the tyConArity, if there are no tyConTyVars). An -example demonstrates these best: say we have a tycon T, with parameters a at -nominal, b at representational, and c at phantom. Then, to prove -representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have -nominal equality between a1 and a2, representational equality between b1 and -b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This -might happen, say, with the following declaration: - - data T a b c where - MkT :: b -> T Int b c - -Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), -as do vanilla synonym tycons. Family tycons have all parameters at role N, -though it is conceivable that we could relax this restriction. (->)'s and -tuples' parameters are at role R. Each primitive tycon declares its roles; -it's worth noting that (~#)'s parameters are at role N. Promoted data -constructors' type arguments are at role R. All kind arguments are at role -N. - -Note [Unboxed tuple RuntimeRep vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The contents of an unboxed tuple may have any representation. Accordingly, -the kind of the unboxed tuple constructor is runtime-representation -polymorphic. - -Type constructor (2 kind arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). - TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) -Data constructor (4 type arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) - (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) - -These extra tyvars (q and r) cause some delicate processing around tuples, -where we need to manually insert RuntimeRep arguments. -The same situation happens with unboxed sums: each alternative -has its own RuntimeRep. -For boxed tuples, there is no levity polymorphism, and therefore -we add RuntimeReps only for the unboxed version. - -Type constructor (no kind arguments) - (,) :: Type -> Type -> Type -Data constructor (2 type arguments) - (,) :: forall a b. a -> b -> (a, b) - - -Note [Injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow injectivity annotations for type families (both open and closed): - - type family F (a :: k) (b :: k) = r | r -> a - type family G a b = res | res -> a b where ... - -Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. -`famTcInj` maybe stores a list of Bools, where each entry corresponds to a -single element of `tyConTyVars` (both lists should have identical length). If no -injectivity annotation was provided `famTcInj` is Nothing. From this follows an -invariant that if `famTcInj` is a Just then at least one element in the list -must be True. - -See also: - * [Injectivity annotation] in GHC.Hs.Decls - * [Renaming injectivity annotation] in GHC.Rename.Source - * [Verifying injectivity annotation] in FamInstEnv - * [Type inference for type families with injectivity] in TcInteract - -************************************************************************ -* * - TyConBinder, TyConTyCoBinder -* * -************************************************************************ --} - -type TyConBinder = VarBndr TyVar TyConBndrVis - --- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really --- contain CoVar. -type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis - -data TyConBndrVis - = NamedTCB ArgFlag - | AnonTCB AnonArgFlag - -instance Outputable TyConBndrVis where - ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag - ppr (AnonTCB af) = text "AnonTCB" <> ppr af - -mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder -mkAnonTyConBinder af tv = ASSERT( isTyVar tv) - Bndr tv (AnonTCB af) - -mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] -mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs - -mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder --- The odd argument order supports currying -mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) - Bndr tv (NamedTCB vis) - -mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] --- The odd argument order supports currying -mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs - --- | Make a Required TyConBinder. It chooses between NamedTCB and --- AnonTCB based on whether the tv is mentioned in the dependent set -mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently - -> TyVar - -> TyConBinder -mkRequiredTyConBinder dep_set tv - | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv - | otherwise = mkAnonTyConBinder VisArg tv - -tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis - -tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag -tyConBndrVisArgFlag (NamedTCB vis) = vis -tyConBndrVisArgFlag (AnonTCB VisArg) = Required -tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] - -isNamedTyConBinder :: TyConBinder -> Bool --- Identifies kind variables --- E.g. data T k (a:k) = blah --- Here 'k' is a NamedTCB, a variable used in the kind of other binders -isNamedTyConBinder (Bndr _ (NamedTCB {})) = True -isNamedTyConBinder _ = False - -isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis - -isVisibleTcbVis :: TyConBndrVis -> Bool -isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis -isVisibleTcbVis (AnonTCB VisArg) = True -isVisibleTcbVis (AnonTCB InvisArg) = False - -isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) - --- Build the 'tyConKind' from the binders and the result kind. --- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. -mkTyConKind :: [TyConBinder] -> Kind -> Kind -mkTyConKind bndrs res_kind = foldr mk res_kind bndrs - where - mk :: TyConBinder -> Kind -> Kind - mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k - mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k - -tyConTyVarBinders :: [TyConBinder] -- From the TyCon - -> [TyVarBinder] -- Suitable for the foralls of a term function --- See Note [Building TyVarBinders from TyConBinders] -tyConTyVarBinders tc_bndrs - = map mk_binder tc_bndrs - where - mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv - where - vis = case tc_vis of - AnonTCB VisArg -> Specified - AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] - NamedTCB Required -> Specified - NamedTCB vis -> vis - --- Returns only tyvars, as covars are always inferred -tyConVisibleTyVars :: TyCon -> [TyVar] -tyConVisibleTyVars tc - = [ tv | Bndr tv vis <- tyConBinders tc - , isVisibleTcbVis vis ] - -{- Note [AnonTCB InvisArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's pretty rare to have an (AnonTCB InvisArg) binder. The -only way it can occur is through equality constraints in kinds. These -can arise in one of two ways: - -* In a PromotedDataCon whose kind has an equality constraint: - - 'MkT :: forall a b. (a~b) => blah - - See Note [Constraints in kinds] in TyCoRep, and - Note [Promoted data constructors] in this module. -* In a data type whose kind has an equality constraint, as in the - following example from #12102: - - data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type - -When mapping an (AnonTCB InvisArg) to an ArgFlag, in -tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot -specify this arguments, even with visible type/kind application; -instead the type checker must fill it in. - -We map (AnonTCB VisArg) to Required, of course: the user must -provide it. It would be utterly wrong to do this for constraint -arguments, which is why AnonTCB must have the AnonArgFlag in -the first place. - -Note [Building TyVarBinders from TyConBinders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We sometimes need to build the quantified type of a value from -the TyConBinders of a type or class. For that we need not -TyConBinders but TyVarBinders (used in forall-type) E.g: - - * From data T a = MkT (Maybe a) - we are going to make a data constructor with type - MkT :: forall a. Maybe a -> T a - See the TyCoVarBinders passed to buildDataCon - - * From class C a where { op :: a -> Maybe a } - we are going to make a default method - $dmop :: forall a. C a => a -> Maybe a - See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType - -Both of these are user-callable. (NB: default methods are not callable -directly by the user but rather via the code generated by 'deriving', -which uses visible type application; see mkDefMethBind.) - -Since they are user-callable we must get their type-argument visibility -information right; and that info is in the TyConBinders. -Here is an example: - - data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * - -The TyCon has - - tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] - -The TyConBinders for App line up with App's kind, given above. - -But the DataCon MkApp has the type - MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b - -That is, its TyCoVarBinders should be - - dataConUnivTyVarBinders = [ Bndr (k:*) Inferred - , Bndr (a:k->*) Specified - , Bndr (b:k) Specified ] - -So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: - - variable names from the TyConBinders - - but changing Anon/Required to Specified - -The last part about Required->Specified comes from this: - data T k (a:k) b = MkT (a b) -Here k is Required in T's kind, but we don't have Required binders in -the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] -in TyCoRep), so we change it to Specified when making MkT's TyCoBinders --} - - -{- Note [The binders/kind/arity fields of a TyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All TyCons have this group of fields - tyConBinders :: [TyConBinder/TyConTyCoBinder] - tyConResKind :: Kind - tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders - -- NB: Currently (Aug 2018), TyCons that own this - -- field really only contain TyVars. So it is - -- [TyVar] instead of [TyCoVar]. - tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders - -They fit together like so: - -* tyConBinders gives the telescope of type/coercion variables on the LHS of the - type declaration. For example: - - type App a (b :: k) = a b - - tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) - , Bndr (a:k->*) AnonTCB - , Bndr (b:k) AnonTCB ] - - Note that that are three binders here, including the - kind variable k. - -* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep - for what the visibility flag means. - -* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and - that TyVar may scope over some other part of the TyCon's definition. Eg - type T a = a -> a - we have - tyConBinders = [ Bndr (a:*) AnonTCB ] - synTcRhs = a -> a - So the 'a' scopes over the synTcRhs - -* From the tyConBinders and tyConResKind we can get the tyConKind - E.g for our App example: - App :: forall k. (k->*) -> k -> * - - We get a 'forall' in the kind for each NamedTCB, and an arrow - for each AnonTCB - - tyConKind is the full kind of the TyCon, not just the result kind - -* For type families, tyConArity is the arguments this TyCon must be - applied to, to be considered saturated. Here we mean "applied to in - the actual Type", not surface syntax; i.e. including implicit kind - variables. So it's just (length tyConBinders) - -* For an algebraic data type, or data instance, the tyConResKind is - always (TYPE r); that is, the tyConBinders are enough to saturate - the type constructor. I'm not quite sure why we have this invariant, - but it's enforced by etaExpandAlgTyCon --} - -instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where - ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) - where - ppr_bi (AnonTCB VisArg) = text "anon-vis" - ppr_bi (AnonTCB InvisArg) = text "anon-invis" - ppr_bi (NamedTCB Required) = text "req" - ppr_bi (NamedTCB Specified) = text "spec" - ppr_bi (NamedTCB Inferred) = text "inf" - -instance Binary TyConBndrVis where - put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } - put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { af <- get bh; return (AnonTCB af) } - _ -> do { vis <- get bh; return (NamedTCB vis) } } - - -{- ********************************************************************* -* * - The TyCon type -* * -************************************************************************ --} - - --- | TyCons represent type constructors. Type constructors are introduced by --- things such as: --- --- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of --- kind @*@ --- --- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor --- --- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor --- of kind @* -> *@ --- --- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor --- of kind @*@ --- --- This data type also encodes a number of primitive, built in type constructors --- such as those for function and tuple types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -data TyCon - = -- | The function type constructor, @(->)@ - FunTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRepName :: TyConRepName - } - - -- | Algebraic data types, from - -- - @data@ declarations - -- - @newtype@ declarations - -- - data instance declarations - -- - type instance declarations - -- - the TyCon generated by a class declaration - -- - boxed tuples - -- - unboxed tuples - -- - constraint tuples - -- All these constructors are lifted and boxed except unboxed tuples - -- which should have an 'UnboxedAlgTyCon' parent. - -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. - -- See 'AlgTyConRhs' for more information. - | AlgTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- The tyConTyVars scope over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data - -- constructors. - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - tyConCType :: Maybe CType,-- ^ The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT - -- syntax? If so, that doesn't mean it's a - -- true GADT; only that the "where" form - -- was used. This field is used only to - -- guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data - -- type (always empty for GADTs). A - -- \"stupid theta\" is the context to - -- the left of an algebraic type - -- declaration, e.g. @Eq a@ in the - -- declaration @data Eq a => T a ...@. - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcFields :: FieldLabelEnv, -- ^ Maps a label to information - -- about the field - - algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration - -- 'TyCon' for derived 'TyCon's representing - -- class or family instances, respectively. - - } - - -- | Represents type synonyms - | SynonymTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - -- tyConTyVars scope over: synTcRhs - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - synTcRhs :: Type, -- ^ Contains information about the expansion - -- of the synonym - - synIsTau :: Bool, -- True <=> the RHS of this synonym does not - -- have any foralls, after expanding any - -- nested synonyms - synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention - -- any type synonym families (data families - -- are fine), again after expanding any - -- nested synonyms - } - - -- | Represents families (both type and data) - -- Argument roles are all Nominal - | FamilyTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - -- tyConTyVars connect an associated family TyCon - -- with its parent class; see TcValidity.checkConsistentFamInst - - famTcResVar :: Maybe Name, -- ^ Name of result type variable, used - -- for pretty-printing with --show-iface - -- and for reifying TyCon in Template - -- Haskell - - famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, - -- abstract, built-in. See comments for - -- FamTyConFlav - - famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families - -- The class tycon in which the family is declared - -- See Note [Associated families and their parent class] - - famTcInj :: Injectivity -- ^ is this a type family injective in - -- its type variables? Nothing if no - -- injectivity annotation was given - } - - -- | Primitive types; cannot be defined in Haskell. This includes - -- the usual suspects (such as @Int#@) as well as foreign-imported - -- types and kinds (@*@, @#@, and @?@) - | PrimTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may - -- not contain bottom) but other are lifted, - -- e.g. @RealWorld@ - -- Only relevant if tyConKind = * - - primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons - -- i.e, *, #, ? - } - - -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConTyCoBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars - dataCon :: DataCon, -- ^ Corresponding data constructor - tcRepName :: TyConRepName, - promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' - } - - -- | These exist only during type-checking. See Note [How TcTyCons work] - -- in TcTyClsDecls - | TcTyCon { - tyConUnique :: Unique, - tyConName :: Name, - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- NB: the TyConArity of a TcTyCon must match - -- the number of Required (positional, user-specified) - -- arguments to the type constructor; see the use - -- of tyConArity in generaliseTcTyCon - - tcTyConScopedTyVars :: [(Name,TyVar)], - -- ^ Scoped tyvars over the tycon's body - -- See Note [Scoped tyvars in a TcTyCon] - - tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? - - tcTyConFlavour :: TyConFlavour - -- ^ What sort of 'TyCon' this represents. - } -{- Note [Scoped tyvars in a TcTyCon] - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcTyConScopedTyVars field records the lexicial-binding connection -between the original, user-specified Name (i.e. thing in scope) and -the TcTyVar that the Name is bound to. - -Order *does* matter; the tcTyConScopedTyvars list consists of - specified_tvs ++ required_tvs - -where - * specified ones first - * required_tvs the same as tyConTyVars - * tyConArity = length required_tvs - -See also Note [How TcTyCons work] in TcTyClsDecls --} - --- | Represents right-hand-sides of 'TyCon's for algebraic types -data AlgTyConRhs - - -- | Says that we know nothing about this data type, except that - -- it's represented by a pointer. Used when we export a data type - -- abstractly into an .hi file. - = AbstractTyCon - - -- | Information about those 'TyCon's derived from a @data@ - -- declaration. This includes data types with no constructors at - -- all. - | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the - -- user declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' - -- tag (see the tag assignment in mkTyConTagMap) - data_cons_size :: Int, - -- ^ Cached value: length data_cons - is_enum :: Bool -- ^ Cached value: is this an enumeration type? - -- See Note [Enumeration types] - } - - | TupleTyCon { -- A boxed, unboxed, or constraint tuple - data_con :: DataCon, -- NB: it can be an *unboxed* tuple - tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint - -- tuple? - } - - -- | An unboxed sum type. - | SumTyCon { - data_cons :: [DataCon], - data_cons_size :: Int -- ^ Cached value: length data_cons - } - - -- | Information about those 'TyCon's derived from a @newtype@ declaration - | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. - -- It has no existentials - - nt_rhs :: Type, -- ^ Cached value: the argument type of the - -- constructor, which is just the representation - -- type of the 'TyCon' (remember that @newtype@s - -- do not exist at runtime so need a different - -- representation type). - -- - -- The free 'TyVar's of this type are the - -- 'tyConTyVars' from the corresponding 'TyCon' - - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom Unbranched, - -- The axiom coercion that creates the @newtype@ - -- from the representation 'Type'. - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check #1072. - nt_lev_poly :: Bool - -- 'True' if the newtype can be levity polymorphic when - -- fully applied to its arguments, 'False' otherwise. - -- This can only ever be 'True' with UnliftedNewtypes. - -- - -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt) - -- - -- This is cached to make it cheaper to check if a - -- variable binding is levity polymorphic, as used by - -- isTcLevPoly. - } - -mkSumTyConRhs :: [DataCon] -> AlgTyConRhs -mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) - -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs cons - = DataTyCon { - data_cons = cons, - data_cons_size = length cons, - is_enum = not (null cons) && all is_enum_con cons - -- See Note [Enumeration types] in TyCon - } - where - is_enum_con con - | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) - <- dataConFullSig con - = null ex_tvs && null eq_spec && null theta && null arg_tys - --- | Some promoted datacons signify extra info relevant to GHC. For example, --- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' --- constructor of 'PrimRep'. This data structure allows us to store this --- information right in the 'TyCon'. The other approach would be to look --- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. --- See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType -data RuntimeRepInfo - = NoRRI -- ^ an ordinary promoted data con - | RuntimeRep ([Type] -> [PrimRep]) - -- ^ A constructor of @RuntimeRep@. The argument to the function should - -- be the list of arguments to the promoted datacon. - | VecCount Int -- ^ A constructor of @VecCount@ - | VecElem PrimElemRep -- ^ A constructor of @VecElem@ - --- | Extract those 'DataCon's that we are able to learn about. Note --- that visibility in this sense does not correspond to visibility in --- the context of any particular user program! -visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons (DataTyCon{ data_cons = cs }) = cs -visibleDataCons (NewTyCon{ data_con = c }) = [c] -visibleDataCons (TupleTyCon{ data_con = c }) = [c] -visibleDataCons (SumTyCon{ data_cons = cs }) = cs - --- ^ Both type classes as well as family instances imply implicit --- type constructors. These implicit type constructors refer to their parent --- structure (ie, the class or family from which they derive) using a type of --- the following form. -data AlgTyConFlav - = -- | An ordinary type constructor has no parent. - VanillaAlgTyCon - TyConRepName -- For Typeable - - -- | An unboxed type constructor. The TyConRepName is a Maybe since we - -- currently don't allow unboxed sums to be Typeable since there are too - -- many of them. See #13276. - | UnboxedAlgTyCon - (Maybe TyConRepName) - - -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in TyCoRep - | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the - -- current tycon - TyConRepName - - -- | Type constructors representing an *instance* of a *data* family. - -- Parameters: - -- - -- 1) The type family in question - -- - -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: - -- the number of types matches the arity of the family 'TyCon' - -- - -- 3) A 'CoTyCon' identifying the representation - -- type with the type instance family - | DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion axiom. - -- A *Representational* coercion, - -- of kind T ty1 ty2 ~R R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon - -- - -- BUT may be eta-reduced; see FamInstEnv - -- Note [Eta reduction for data families] - - -- Cached fields of the CoAxiom, but adjusted to - -- use the tyConTyVars of this TyCon - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in FamInstEnv - - -- E.g. data instance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcParent = DataFamInstTyCon T [a] co - -instance Outputable AlgTyConFlav where - ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" - ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" - ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls - ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" - <+> ppr tc <+> sep (map pprType tys) - --- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class --- name, if any -okParent :: Name -> AlgTyConFlav -> Bool -okParent _ (VanillaAlgTyCon {}) = True -okParent _ (UnboxedAlgTyCon {}) = True -okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) -okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc - -isNoParent :: AlgTyConFlav -> Bool -isNoParent (VanillaAlgTyCon {}) = True -isNoParent _ = False - --------------------- - -data Injectivity - = NotInjective - | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) - deriving( Eq ) - --- | Information pertaining to the expansion of a type synonym (@type@) -data FamTyConFlav - = -- | Represents an open type family without a fixed right hand - -- side. Additional instances can appear at any time. - -- - -- These are introduced by either a top level declaration: - -- - -- > data family T a :: * - -- - -- Or an associated data type declaration, within a class declaration: - -- - -- > class C a b where - -- > data T b :: * - DataFamilyTyCon - TyConRepName - - -- | An open type synonym family e.g. @type family F x y :: * -> *@ - | OpenSynFamilyTyCon - - -- | A closed type synonym family e.g. - -- @type family F x where { F Int = Bool }@ - | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) - -- See Note [Closed type families] - - -- | A closed type synonym family declared in an hs-boot file with - -- type family F a where .. - | AbstractClosedSynFamilyTyCon - - -- | Built-in type family used by the TypeNats solver - | BuiltInSynFamTyCon BuiltInSynFamily - -instance Outputable FamTyConFlav where - ppr (DataFamilyTyCon n) = text "data family" <+> ppr n - ppr OpenSynFamilyTyCon = text "open type family" - ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" - ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax - ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" - ppr (BuiltInSynFamTyCon _) = text "built-in type family" - -{- Note [Closed type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* In an open type family you can add new instances later. This is the - usual case. - -* In a closed type family you can only put equations where the family - is defined. - -A non-empty closed type family has a single axiom with multiple -branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed -type family with no equations does not have an axiom, because there is -nothing for the axiom to prove! - - -Note [Promoted data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All data constructors can be promoted to become a type constructor, -via the PromotedDataCon alternative in TyCon. - -* The TyCon promoted from a DataCon has the *same* Name and Unique as - the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, - say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) - -* We promote the *user* type of the DataCon. Eg - data T = MkT {-# UNPACK #-} !(Bool, Bool) - The promoted kind is - 'MkT :: (Bool,Bool) -> T - *not* - 'MkT :: Bool -> Bool -> T - -* Similarly for GADTs: - data G a where - MkG :: forall b. b -> G [b] - The promoted data constructor has kind - 'MkG :: forall b. b -> G [b] - *not* - 'MkG :: forall a b. (a ~# [b]) => b -> G a - -Note [Enumeration types] -~~~~~~~~~~~~~~~~~~~~~~~~ -We define datatypes with no constructors to *not* be -enumerations; this fixes trac #2578, Otherwise we -end up generating an empty table for - __closure_tbl -which is used by tagToEnum# to map Int# to constructors -in an enumeration. The empty table apparently upset -the linker. - -Moreover, all the data constructor must be enumerations, meaning -they have type (forall abc. T a b c). GADTs are not enumerations. -For example consider - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a -What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. -See #4528. - -Note [Newtype coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -The NewTyCon field nt_co is a CoAxiom which is used for coercing from -the representation type of the newtype, to the newtype itself. For -example, - - newtype T a = MkT (a -> a) - -the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. - -In the case that the right hand side is a type application -ending with the same type variables as the left hand side, we -"eta-contract" the coercion. So if we had - - newtype S a = MkT [a] - -then we would generate the arity 0 axiom CoS : S ~ []. The -primary reason we do this is to make newtype deriving cleaner. - -In the paper we'd write - axiom CoT : (forall t. T t) ~ (forall t. [t]) -and then when we used CoT at a particular type, s, we'd say - CoT @ s -which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) - -Note [Newtype eta] -~~~~~~~~~~~~~~~~~~ -Consider - newtype Parser a = MkParser (IO a) deriving Monad -Are these two types equal (to Core)? - Monad Parser - Monad IO -which we need to make the derived instance for Monad Parser. - -Well, yes. But to see that easily we eta-reduce the RHS type of -Parser, in this case to ([], Froogle), so that even unsaturated applications -of Parser will work right. This eta reduction is done when the type -constructor is built, and cached in NewTyCon. - -Here's an example that I think showed up in practice -Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) - - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) - -After desugaring, and discarding the data constructors for the newtypes, -we get: - w2 = w1 `cast` Foo CoT -so the coercion tycon CoT must have - kind: T ~ [] - and arity: 0 - -This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs. - - -************************************************************************ -* * - TyConRepName -* * -********************************************************************* -} - -type TyConRepName = Name - -- The Name of the top-level declaration for the Typeable world - -- $tcMaybe :: Data.Typeable.Internal.TyCon - -- $tcMaybe = TyCon { tyConName = "Maybe", ... } - -tyConRepName_maybe :: TyCon -> Maybe TyConRepName -tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) - = Just rep_nm -tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) - = mb_rep_nm -tyConRepName_maybe (AlgTyCon { algTcParent = parent }) - | VanillaAlgTyCon rep_nm <- parent = Just rep_nm - | ClassTyCon _ rep_nm <- parent = Just rep_nm - | UnboxedAlgTyCon rep_nm <- parent = rep_nm -tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) - = Just rep_nm -tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) - | isUnboxedSumCon dc -- see #13276 - = Nothing - | otherwise - = Just rep_nm -tyConRepName_maybe _ = Nothing - --- | Make a 'Name' for the 'Typeable' representation of the given wired-in type -mkPrelTyConRepName :: Name -> TyConRepName --- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. -mkPrelTyConRepName tc_name -- Prelude tc_name is always External, - -- so nameModule will work - = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) - where - name_occ = nameOccName tc_name - name_mod = nameModule tc_name - name_uniq = nameUnique tc_name - rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq - | otherwise = dataConTyRepNameUnique name_uniq - (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ - --- | The name (and defining module) for the Typeable representation (TyCon) of a --- type constructor. --- --- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. -tyConRepModOcc :: Module -> OccName -> (Module, OccName) -tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) - where - rep_module - | tc_module == gHC_PRIM = gHC_TYPES - | otherwise = tc_module - - -{- ********************************************************************* -* * - PrimRep -* * -************************************************************************ - -Note [rep swamp] - -GHC has a rich selection of types that represent "primitive types" of -one kind or another. Each of them makes a different set of -distinctions, and mostly the differences are for good reasons, -although it's probably true that we could merge some of these. - -Roughly in order of "includes more information": - - - A Width (cmm/CmmType) is simply a binary value with the specified - number of bits. It may represent a signed or unsigned integer, a - floating-point value, or an address. - - data Width = W8 | W16 | W32 | W64 | W128 - - - Size, which is used in the native code generator, is Width + - floating point information. - - data Size = II8 | II16 | II32 | II64 | FF32 | FF64 - - it is necessary because e.g. the instruction to move a 64-bit float - on x86 (movsd) is different from the instruction to move a 64-bit - integer (movq), so the mov instruction is parameterised by Size. - - - CmmType wraps Width with more information: GC ptr, float, or - other value. - - data CmmType = CmmType CmmCat Width - - data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - - It is important to have GcPtr information in Cmm, since we generate - info tables containing pointerhood for the GC from this. As for - why we have float (and not signed/unsigned) here, see Note [Signed - vs unsigned]. - - - ArgRep makes only the distinctions necessary for the call and - return conventions of the STG machine. It is essentially CmmType - + void. - - - PrimRep makes a few more distinctions than ArgRep: it divides - non-GC-pointers into signed/unsigned and addresses, information - that is necessary for passing these values to foreign functions. - -There's another tension here: whether the type encodes its size in -bytes, or whether its size depends on the machine word size. Width -and CmmType have the size built-in, whereas ArgRep and PrimRep do not. - -This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. - -On the other hand, CmmType includes some "nonsense" values, such as -CmmType GcPtrCat W32 on a 64-bit machine. - -The PrimRep type is closely related to the user-visible RuntimeRep type. -See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. - --} - --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, --- and store values of this type. See also Note [RuntimeRep and PrimRep] in --- GHC.Types.RepType and Note [VoidRep] in GHC.Types.RepType. -data PrimRep - = VoidRep - | LiftedRep - | UnliftedRep -- ^ Unlifted pointer - | Int8Rep -- ^ Signed, 8-bit value - | Int16Rep -- ^ Signed, 16-bit value - | Int32Rep -- ^ Signed, 32-bit value - | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) - | IntRep -- ^ Signed, word-sized value - | Word8Rep -- ^ Unsigned, 8 bit value - | Word16Rep -- ^ Unsigned, 16 bit value - | Word32Rep -- ^ Unsigned, 32 bit value - | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) - | WordRep -- ^ Unsigned, word-sized value - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') - | FloatRep - | DoubleRep - | VecRep Int PrimElemRep -- ^ A vector - deriving( Show ) - -data PrimElemRep - = Int8ElemRep - | Int16ElemRep - | Int32ElemRep - | Int64ElemRep - | Word8ElemRep - | Word16ElemRep - | Word32ElemRep - | Word64ElemRep - | FloatElemRep - | DoubleElemRep - deriving( Eq, Show ) - -instance Outputable PrimRep where - ppr r = text (show r) - -instance Outputable PrimElemRep where - ppr r = text (show r) - -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - -isGcPtrRep :: PrimRep -> Bool -isGcPtrRep LiftedRep = True -isGcPtrRep UnliftedRep = True -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 = - (isUnboxed rep1 == isUnboxed rep2) && - (primRepSizeB dflags rep1 == primRepSizeB dflags 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 = - length reps1 == length reps2 && - and (zipWith (primRepCompatible dflags) reps1 reps2) - --- | The size of a 'PrimRep' in bytes. --- --- This applies also when used in a constructor, where we allow packing the --- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will --- 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 - -primElemRepSizeB :: PrimElemRep -> Int -primElemRepSizeB Int8ElemRep = 1 -primElemRepSizeB Int16ElemRep = 2 -primElemRepSizeB Int32ElemRep = 4 -primElemRepSizeB Int64ElemRep = 8 -primElemRepSizeB Word8ElemRep = 1 -primElemRepSizeB Word16ElemRep = 2 -primElemRepSizeB Word32ElemRep = 4 -primElemRepSizeB Word64ElemRep = 8 -primElemRepSizeB FloatElemRep = 4 -primElemRepSizeB DoubleElemRep = 8 - --- | Return if Rep stands for floating type, --- returns Nothing for vector types. -primRepIsFloat :: PrimRep -> Maybe Bool -primRepIsFloat FloatRep = Just True -primRepIsFloat DoubleRep = Just True -primRepIsFloat (VecRep _ _) = Nothing -primRepIsFloat _ = Just False - - -{- -************************************************************************ -* * - Field labels -* * -************************************************************************ --} - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabels :: TyCon -> [FieldLabel] -tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabelEnv :: TyCon -> FieldLabelEnv -tyConFieldLabelEnv tc - | isAlgTyCon tc = algTcFields tc - | otherwise = emptyDFsEnv - --- | Look up a field label belonging to this 'TyCon' -lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel -lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl - --- | Make a map from strings to FieldLabels from all the data --- constructors of this algebraic tycon -fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv -fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) - | fl <- dataConsFields (visibleDataCons rhs) ] - where - -- Duplicates in this list will be removed by 'mkFsEnv' - dataConsFields dcs = concatMap dataConFieldLabels dcs - - -{- -************************************************************************ -* * -\subsection{TyCon Construction} -* * -************************************************************************ - -Note: the TyCon constructors all take a Kind as one argument, even though -they could, in principle, work out their Kind from their other arguments. -But to do so they need functions from Types, and that makes a nasty -module mutual-recursion. And they aren't called from many places. -So we compromise, and move their Kind calculation to the call site. --} - --- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is recommended to use 'TyCoRep.funTyCon' if you want --- this functionality -mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon -mkFunTyCon name binders rep_nm - = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConResKind = liftedTypeKind, - tyConKind = mkTyConKind binders liftedTypeKind, - tyConArity = length binders, - tcRepName = rep_nm - } - --- | This is the making of an algebraic 'TyCon'. Notably, you have to --- pass in the generic (in the -XGenerics sense) information about the --- type constructor - you can get hold of it easily (see Generics --- module) -mkAlgTyCon :: Name - -> [TyConBinder] -- ^ Binders of the 'TyCon' - -> Kind -- ^ Result kind - -> [Role] -- ^ The roles for each TyVar - -> Maybe CType -- ^ The C type this type corresponds to - -- when using the CAPI FFI - -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about data constructors - -> AlgTyConFlav -- ^ What flavour is it? - -- (e.g. vanilla, type family) - -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> TyCon -mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - tyConCType = cType, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcFields = fieldsOfAlgTcRhs rhs, - algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, - algTcGadtSyntax = gadt_syn - } - --- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> [TyConBinder] - -> [Role] -> AlgTyConRhs -> Class - -> Name -> TyCon -mkClassTyCon name binders roles rhs clas tc_rep_name - = mkAlgTyCon name binders constraintKind roles Nothing [] rhs - (ClassTyCon clas tc_rep_name) - False - -mkTupleTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Result kind of the 'TyCon' - -> Arity -- ^ Arity of the tuple 'TyCon' - -> DataCon - -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> AlgTyConFlav - -> TyCon -mkTupleTyCon name binders res_kind arity con sort parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = binderVars binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, - tup_sort = sort }, - algTcFields = emptyDFsEnv, - algTcParent = parent - } - -mkSumTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Kind of the resulting 'TyCon' - -> Arity -- ^ Arity of the sum - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> [DataCon] - -> AlgTyConFlav - -> TyCon -mkSumTyCon name binders res_kind arity tyvars cons parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = tyvars, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = mkSumTyConRhs cons, - algTcFields = emptyDFsEnv, - algTcParent = parent - } - --- | Makes a tycon suitable for use during type-checking. It stores --- a variety of details about the definition of the TyCon, but no --- right-hand side. It lives only during the type-checking of a --- mutually-recursive group of tycons; it is then zonked to a proper --- TyCon in zonkTcTyCon. --- See also Note [Kind checking recursive type and class declarations] --- in TcTyClsDecls. -mkTcTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ /result/ kind only - -> [(Name,TcTyVar)] -- ^ Scoped type variables; - -- see Note [How TcTyCons work] in TcTyClsDecls - -> Bool -- ^ Is this TcTyCon generalised already? - -> TyConFlavour -- ^ What sort of 'TyCon' this represents - -> TyCon -mkTcTyCon name binders res_kind scoped_tvs poly flav - = TcTyCon { tyConUnique = getUnique name - , tyConName = name - , tyConTyVars = binderVars binders - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tcTyConScopedTyVars = scoped_tvs - , tcTyConIsPoly = poly - , tcTyConFlavour = flav } - --- | No scoped type variables (to be used with mkTcTyCon). -noTcTyConScopedTyVars :: [(Name, TcTyVar)] -noTcTyConScopedTyVars = [] - --- | Create an unlifted primitive 'TyCon', such as @Int#@. -mkPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind, never levity-polymorphic - -> [Role] -> TyCon -mkPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) - --- | Kind constructors -mkKindTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> Name -> TyCon -mkKindTyCon name binders res_kind roles rep_nm - = tc - where - tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) - --- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> TyCon -mkLiftedPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) - where rep_nm = mkPrelTyConRepName name - -mkPrimTyCon' :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind, never levity-polymorphic - -- (If you need a levity-polymorphic PrimTyCon, change - -- isTcLevPoly.) - -> [Role] - -> Bool -> Maybe TyConRepName -> TyCon -mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm - = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length roles, - tcRoles = roles, - isUnlifted = is_unlifted, - primRepName = rep_nm - } - --- | Create a type synonym 'TyCon' -mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> Bool -> Bool -> TyCon -mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free - = SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free - } - --- | Create a type family 'TyCon' -mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> Maybe Name -> FamTyConFlav - -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name binders res_kind resVar flav parent inj - = FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConTyVars = binderVars binders - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = classTyCon <$> parent - , famTcInj = inj - } - - --- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the data constructor itself; when we pretty-print --- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConTyCoBinder] -> Kind -> [Role] - -> RuntimeRepInfo -> TyCon -mkPromotedDataCon con name rep_name binders res_kind roles rep_info - = PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = length roles, - tcRoles = roles, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - dataCon = con, - tcRepName = rep_name, - promDcRepInfo = rep_info - } - -isFunTyCon :: TyCon -> Bool -isFunTyCon (FunTyCon {}) = True -isFunTyCon _ = False - --- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) -isAbstractTyCon :: TyCon -> Bool -isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True -isAbstractTyCon _ = False - --- | Does this 'TyCon' represent something that cannot be defined in Haskell? -isPrimTyCon :: TyCon -> Bool -isPrimTyCon (PrimTyCon {}) = True -isPrimTyCon _ = False - --- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can --- only be true for primitive and unboxed-tuple 'TyCon's -isUnliftedTyCon :: TyCon -> Bool -isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) - = is_unlifted -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | SumTyCon {} <- rhs - = True -isUnliftedTyCon _ = False - --- | Returns @True@ if the supplied 'TyCon' resulted from either a --- @data@ or @newtype@ declaration -isAlgTyCon :: TyCon -> Bool -isAlgTyCon (AlgTyCon {}) = True -isAlgTyCon _ = False - --- | Returns @True@ for vanilla AlgTyCons -- that is, those created --- with a @data@ or @newtype@ declaration. -isVanillaAlgTyCon :: TyCon -> Bool -isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True -isVanillaAlgTyCon _ = False - -isDataTyCon :: TyCon -> Bool --- ^ Returns @True@ for data types that are /definitely/ represented by --- heap-allocated constructors. These are scrutinised by Core-level --- @case@ expressions, and they get info tables allocated for them. --- --- Generally, the function will be true for all @data@ types and false --- for @newtype@s, unboxed tuples, unboxed sums and type family --- 'TyCon's. But it is not guaranteed to return @True@ in all cases --- that it could. --- --- NB: for a data type family, only the /instance/ 'TyCon's --- get an info table. The family declaration 'TyCon' does not -isDataTyCon (AlgTyCon {algTcRhs = rhs}) - = case rhs of - TupleTyCon { tup_sort = sort } - -> isBoxed (tupleSortBoxity sort) - SumTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon _ = False - --- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) --- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) --- See also Note [Decomposing equality] in TcCanonical -isInjectiveTyCon :: TyCon -> Role -> Bool -isInjectiveTyCon _ Phantom = False -isInjectiveTyCon (FunTyCon {}) _ = True -isInjectiveTyCon (AlgTyCon {}) Nominal = True -isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational - = isGenInjAlgRhs rhs -isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) - Nominal = True -isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj -isInjectiveTyCon (FamilyTyCon {}) _ = False -isInjectiveTyCon (PrimTyCon {}) _ = True -isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (TcTyCon {}) _ = True - -- Reply True for TcTyCon to minimise knock on type errors - -- See Note [How TcTyCons work] item (1) in TcTyClsDecls - --- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T tys ~X t), then (t's head ~X T). --- See also Note [Decomposing equality] in TcCanonical -isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True -isGenerativeTyCon (FamilyTyCon {}) _ = False - -- in all other cases, injectivity implies generativity -isGenerativeTyCon tc r = isInjectiveTyCon tc r - --- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective --- with respect to representational equality? -isGenInjAlgRhs :: AlgTyConRhs -> Bool -isGenInjAlgRhs (TupleTyCon {}) = True -isGenInjAlgRhs (SumTyCon {}) = True -isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (AbstractTyCon {}) = False -isGenInjAlgRhs (NewTyCon {}) = False - --- | Is this 'TyCon' that for a @newtype@ -isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon _ = False - --- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it --- expands into, and (possibly) a coercion from the representation type to the --- @newtype@. --- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) -unwrapNewTyCon_maybe _ = Nothing - -unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, - nt_etad_rhs = (tvs,rhs) }}) - = Just (tvs, rhs, co) -unwrapNewTyConEtad_maybe _ = Nothing - -isProductTyCon :: TyCon -> Bool --- True of datatypes or newtypes that have --- one, non-existential, data constructor --- See Note [Product types] -isProductTyCon tc@(AlgTyCon {}) - = case algTcRhs tc of - TupleTyCon {} -> True - DataTyCon{ data_cons = [data_con] } - -> null (dataConExTyCoVars data_con) - NewTyCon {} -> True - _ -> False -isProductTyCon _ = False - -isDataProductTyCon_maybe :: TyCon -> Maybe DataCon --- True of datatypes (not newtypes) with --- one, vanilla, data constructor --- See Note [Product types] -isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [con] } - | null (dataConExTyCoVars con) -- non-existential - -> Just con - TupleTyCon { data_con = con } - -> Just con - _ -> Nothing -isDataProductTyCon_maybe _ = Nothing - -isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] -isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = cons } - | cons `lengthExceeds` 1 - , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - SumTyCon { data_cons = cons } - | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - _ -> Nothing -isDataSumTyCon_maybe _ = Nothing - -{- Note [Product types] -~~~~~~~~~~~~~~~~~~~~~~~ -A product type is - * A data type (not a newtype) - * With one, boxed data constructor - * That binds no existential type variables - -The main point is that product types are amenable to unboxing for - * Strict function calls; we can transform - f (D a b) = e - to - fw a b = e - via the worker/wrapper transformation. (Question: couldn't this - work for existentials too?) - - * CPR for function results; we can transform - f x y = let ... in D a b - to - fw x y = let ... in (# a, b #) - -Note that the data constructor /can/ have evidence arguments: equality -constraints, type classes etc. So it can be GADT. These evidence -arguments are simply value arguments, and should not get in the way. --} - - --- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? -isTypeSynonymTyCon :: TyCon -> Bool -isTypeSynonymTyCon (SynonymTyCon {}) = True -isTypeSynonymTyCon _ = False - -isTauTyCon :: TyCon -> Bool -isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau -isTauTyCon _ = True - -isFamFreeTyCon :: TyCon -> Bool -isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free -isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isFamFreeTyCon _ = True - --- As for newtypes, it is in some contexts important to distinguish between --- closed synonyms and synonym families, as synonym families have no unique --- right hand side to which a synonym family application can expand. --- - --- | True iff we can decompose (T a b c) into ((T a b) c) --- I.e. is it injective and generative w.r.t nominal equality? --- That is, if (T a b) ~N d e f, is it always the case that --- (T ~N d), (a ~N e) and (b ~N f)? --- Specifically NOT true of synonyms (open and otherwise) --- --- It'd be unusual to call mustBeSaturated on a regular H98 --- type synonym, because you should probably have expanded it first --- But regardless, it's not decomposable -mustBeSaturated :: TyCon -> Bool -mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour - --- | Is this an algebraic 'TyCon' declared with the GADT syntax? -isGadtSyntaxTyCon :: TyCon -> Bool -isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res -isGadtSyntaxTyCon _ = False - --- | Is this an algebraic 'TyCon' which is just an enumeration of values? -isEnumerationTyCon :: TyCon -> Bool --- See Note [Enumeration types] in TyCon -isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) - = case rhs of - DataTyCon { is_enum = res } -> res - TupleTyCon {} -> arity == 0 - _ -> False -isEnumerationTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family? -isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (FamilyTyCon {}) = True -isFamilyTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family with --- instances? -isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) - | OpenSynFamilyTyCon <- flav = True - | DataFamilyTyCon {} <- flav = True -isOpenFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isTypeFamilyTyCon :: TyCon -> Bool -isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) -isTypeFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isDataFamilyTyCon :: TyCon -> Bool -isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isDataFamilyTyCon _ = False - --- | Is this an open type family TyCon? -isOpenTypeFamilyTyCon :: TyCon -> Bool -isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True -isOpenTypeFamilyTyCon _ = False - --- | Is this a non-empty closed type family? Returns 'Nothing' for --- abstract or empty closed families. -isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) -isClosedSynFamilyTyConWithAxiom_maybe - (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb -isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing - --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an --- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is --- injective), or 'NotInjective' otherwise. -tyConInjectivityInfo :: TyCon -> Injectivity -tyConInjectivityInfo tc - | FamilyTyCon { famTcInj = inj } <- tc - = inj - | isInjectiveTyCon tc Nominal - = Injective (replicate (tyConArity tc) True) - | otherwise - = NotInjective - -isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily -isBuiltInSynFamTyCon_maybe - (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops -isBuiltInSynFamTyCon_maybe _ = Nothing - -isDataFamFlav :: FamTyConFlav -> Bool -isDataFamFlav (DataFamilyTyCon {}) = True -- Data family -isDataFamFlav _ = False -- Type synonym family - --- | Is this TyCon for an associated type? -isTyConAssoc :: TyCon -> Bool -isTyConAssoc = isJust . tyConAssoc_maybe - --- | Get the enclosing class TyCon (if there is one) for the given TyCon. -tyConAssoc_maybe :: TyCon -> Maybe TyCon -tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour - --- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour -tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon -tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe _ = Nothing - --- The unit tycon didn't used to be classed as a tuple tycon --- but I thought that was silly so I've undone it --- If it can't be for some reason, it should be a AlgTyCon -isTupleTyCon :: TyCon -> Bool --- ^ Does this 'TyCon' represent a tuple? --- --- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to --- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they --- get spat into the interface file as tuple tycons, so I don't think --- it matters. -isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True -isTupleTyCon _ = False - -tyConTuple_maybe :: TyCon -> Maybe TupleSort -tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort} <- rhs = Just sort -tyConTuple_maybe _ = Nothing - --- | Is this the 'TyCon' for an unboxed tuple? -isUnboxedTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnboxedTupleTyCon _ = False - --- | Is this the 'TyCon' for a boxed tuple? -isBoxedTupleTyCon :: TyCon -> Bool -isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = isBoxed (tupleSortBoxity sort) -isBoxedTupleTyCon _ = False - --- | Is this the 'TyCon' for an unboxed sum? -isUnboxedSumTyCon :: TyCon -> Bool -isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) - | SumTyCon {} <- rhs - = True -isUnboxedSumTyCon _ = False - --- | Is this the 'TyCon' for a /promoted/ tuple? -isPromotedTupleTyCon :: TyCon -> Bool -isPromotedTupleTyCon tyCon - | Just dataCon <- isPromotedDataCon_maybe tyCon - , isTupleTyCon (dataConTyCon dataCon) = True - | otherwise = False - --- | Is this a PromotedDataCon? -isPromotedDataCon :: TyCon -> Bool -isPromotedDataCon (PromotedDataCon {}) = True -isPromotedDataCon _ = False - --- | Retrieves the promoted DataCon if this is a PromotedDataCon; -isPromotedDataCon_maybe :: TyCon -> Maybe DataCon -isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc -isPromotedDataCon_maybe _ = Nothing - --- | Is this tycon really meant for use at the kind level? That is, --- should it be permitted without -XDataKinds? -isKindTyCon :: TyCon -> Bool -isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys - --- | These TyCons should be allowed at the kind level, even without --- -XDataKinds. -kindTyConKeys :: UniqSet Unique -kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] - : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon - , vecCountTyCon, vecElemTyCon ] ) - where - tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) - -isLiftedTypeKindTyConName :: Name -> Bool -isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) - --- | Identifies implicit tycons that, in particular, do not go into interface --- files (because they are implicitly reconstructed when the interface is --- read). --- --- Note that: --- --- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and --- --- * Family instances are /not/ implicit as they represent the instance body --- (similar to a @dfun@ does that for a class instance). --- --- * Tuples are implicit iff they have a wired-in name --- (namely: boxed and unboxed tuples are wired-in and implicit, --- but constraint tuples are not) -isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon (FunTyCon {}) = True -isImplicitTyCon (PrimTyCon {}) = True -isImplicitTyCon (PromotedDataCon {}) = True -isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) - | TupleTyCon {} <- rhs = isWiredInName name - | SumTyCon {} <- rhs = True - | otherwise = False -isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent -isImplicitTyCon (SynonymTyCon {}) = False -isImplicitTyCon (TcTyCon {}) = False - -tyConCType_maybe :: TyCon -> Maybe CType -tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc -tyConCType_maybe _ = Nothing - --- | Is this a TcTyCon? (That is, one only used during type-checking?) -isTcTyCon :: TyCon -> Bool -isTcTyCon (TcTyCon {}) = True -isTcTyCon _ = False - -setTcTyConKind :: TyCon -> Kind -> TyCon --- Update the Kind of a TcTyCon --- The new kind is always a zonked version of its previous --- kind, so we don't need to update any other fields. --- See Note [The Purely Kinded Invariant] in TcHsType -setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } -setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) - --- | Could this TyCon ever be levity-polymorphic when fully applied? --- True is safe. False means we're sure. Does only a quick check --- based on the TyCon's category. --- Precondition: The fully-applied TyCon has kind (TYPE blah) -isTcLevPoly :: TyCon -> Bool -isTcLevPoly FunTyCon{} = False -isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) - | UnboxedAlgTyCon _ <- parent - = True - | NewTyCon { nt_lev_poly = lev_poly } <- rhs - = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360) - | otherwise - = False -isTcLevPoly SynonymTyCon{} = True -isTcLevPoly FamilyTyCon{} = True -isTcLevPoly PrimTyCon{} = False -isTcLevPoly TcTyCon{} = False -isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) - -{- ------------------------------------------------ --- Expand type-constructor applications ------------------------------------------------ --} - -expandSynTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body - -- type of the synonym (not yet substituted) - -- and any arguments remaining from the - -- application - --- ^ Expand a type synonym application, if any -expandSynTyCon_maybe tc tys - | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc - = case tys `listLengthCmp` arity of - GT -> Just (tvs `zip` tys, rhs, drop arity tys) - EQ -> Just (tvs `zip` tys, rhs, []) - LT -> Nothing - | otherwise - = Nothing - ----------------- - --- | Check if the tycon actually refers to a proper `data` or `newtype` --- with user defined constructors rather than one from a class or other --- construction. - --- NB: This is only used in TcRnExports.checkPatSynParent to determine if an --- exported tycon can have a pattern synonym bundled with it, e.g., --- module Foo (TyCon(.., PatSyn)) where -isTyConWithSrcDataCons :: TyCon -> Bool -isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = - case rhs of - DataTyCon {} -> isSrcParent - NewTyCon {} -> isSrcParent - TupleTyCon {} -> isSrcParent - _ -> False - where - isSrcParent = isNoParent parent -isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) - = True -- #14058 -isTyConWithSrcDataCons _ = False - - --- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no --- constructors could be found -tyConDataCons :: TyCon -> [DataCon] --- It's convenient for tyConDataCons to return the --- empty list for type synonyms etc -tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] - --- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' --- is the sort that can have any constructors (note: this does not include --- abstract algebraic types) -tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) - = case rhs of - DataTyCon { data_cons = cons } -> Just cons - NewTyCon { data_con = con } -> Just [con] - TupleTyCon { data_con = con } -> Just [con] - SumTyCon { data_cons = cons } -> Just cons - _ -> Nothing -tyConDataCons_maybe _ = Nothing - --- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ --- type with one alternative, a tuple type or a @newtype@ then that constructor --- is returned. If the 'TyCon' has more than one constructor, or represents a --- primitive or function type constructor then @Nothing@ is returned. In any --- other case, the function panics -tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - NewTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleDataCon_maybe _ = Nothing - -tyConSingleDataCon :: TyCon -> DataCon -tyConSingleDataCon tc - = case tyConSingleDataCon_maybe tc of - Just c -> c - Nothing -> pprPanic "tyConDataCon" (ppr tc) - -tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon --- Returns (Just con) for single-constructor --- *algebraic* data types *not* newtypes -tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleAlgDataCon_maybe _ = Nothing - --- | Determine the number of value constructors a 'TyCon' has. Panics if the --- 'TyCon' is not algebraic or a tuple -tyConFamilySize :: TyCon -> Int -tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons_size = size } -> size - NewTyCon {} -> 1 - TupleTyCon {} -> 1 - SumTyCon { data_cons_size = size } -> size - _ -> pprPanic "tyConFamilySize 1" (ppr tc) -tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) - --- | Extract an 'AlgTyConRhs' with information about data constructors from an --- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs other = pprPanic "algTyConRhs" (ppr other) - --- | Extract type variable naming the result of injective type family -tyConFamilyResVar_maybe :: TyCon -> Maybe Name -tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res -tyConFamilyResVar_maybe _ = Nothing - --- | Get the list of roles for the type parameters of a TyCon -tyConRoles :: TyCon -> [Role] --- See also Note [TyCon Role signatures] -tyConRoles tc - = case tc of - { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] - ; AlgTyCon { tcRoles = roles } -> roles - ; SynonymTyCon { tcRoles = roles } -> roles - ; FamilyTyCon {} -> const_role Nominal - ; PrimTyCon { tcRoles = roles } -> roles - ; PromotedDataCon { tcRoles = roles } -> roles - ; TcTyCon {} -> const_role Nominal - } - where - const_role r = replicate (tyConArity tc) r - --- | Extract the bound type variables and type expansion of a type synonym --- 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) - = (tvs, rhs) -newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) - --- | The number of type parameters that need to be passed to a newtype to --- resolve it. May be less than in the definition if it can be eta-contracted. -newTyConEtadArity :: TyCon -> Int -newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) - = length (fst tvs_rhs) -newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) - --- | Extract the bound type variables and type expansion of an eta-contracted --- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConEtadRhs :: TyCon -> ([TyVar], Type) -newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs -newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) - --- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to --- construct something with the @newtype@s type from its representation type --- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns --- @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing - -newTyConCo :: TyCon -> CoAxiom Unbranched -newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co - Nothing -> pprPanic "newTyConCo" (ppr tc) - -newTyConDataCon_maybe :: TyCon -> Maybe DataCon -newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con -newTyConDataCon_maybe _ = Nothing - --- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context --- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration --- @data Eq a => T a ...@ -tyConStupidTheta :: TyCon -> [PredType] -tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta (FunTyCon {}) = [] -tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) - --- | Extract the 'TyVar's bound by a vanilla type synonym --- and the corresponding (unsubstituted) right hand side. -synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) -synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) - = Just (tyvars, ty) -synTyConDefn_maybe _ = Nothing - --- | Extract the information pertaining to the right hand side of a type synonym --- (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe Type -synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs -synTyConRhs_maybe _ = Nothing - --- | Extract the flavour of a type family (with all the extra information that --- it carries) -famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav -famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav -famTyConFlav_maybe _ = Nothing - --- | Is this 'TyCon' that for a class instance? -isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True -isClassTyCon _ = False - --- | If this 'TyCon' is that for a class instance, return the class it is for. --- Otherwise returns @Nothing@ -tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas -tyConClass_maybe _ = Nothing - --- | Return the associated types of the 'TyCon', if any -tyConATs :: TyCon -> [TyCon] -tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas -tyConATs _ = [] - ----------------------------------------------------------------------------- --- | Is this 'TyCon' that for a data family instance? -isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) - = True -isFamInstTyCon _ = False - -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) -tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) - = Just (f, ts, ax) -tyConFamInstSig_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return the family in question --- and the instance types. Otherwise, return @Nothing@ -tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) - = Just (f, ts) -tyConFamInst_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which --- represents a coercion identifying the representation type with the type --- instance family. Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) - = Just ax -tyConFamilyCoercion_maybe _ = Nothing - --- | Extract any 'RuntimeRepInfo' from this TyCon -tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo -tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri -tyConRuntimeRepInfo _ = NoRRI - -- could panic in that second case. But Douglas Adams told me not to. - -{- -Note [Constructor tag allocation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking we need to allocate constructor tags to constructors. -They are allocated based on the position in the data_cons field of TyCon, -with the first constructor getting fIRST_TAG. - -We used to pay linear cost per constructor, with each constructor looking up -its relative index in the constructor list. That was quadratic and prohibitive -for large data types with more than 10k constructors. - -The current strategy is to build a NameEnv with a mapping from constructor's -Name to ConTag and pass it down to buildDataCon for efficient lookup. - -Relevant ticket: #14657 --} - -mkTyConTagMap :: TyCon -> NameEnv ConTag -mkTyConTagMap tycon = - mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] - -- See Note [Constructor tag allocation] - -{- -************************************************************************ -* * -\subsection[TyCon-instances]{Instance declarations for @TyCon@} -* * -************************************************************************ - -@TyCon@s are compared by comparing their @Unique@s. --} - -instance Eq TyCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable TyCon where - getUnique tc = tyConUnique tc - -instance Outputable TyCon where - -- At the moment a promoted TyCon has the same Name as its - -- corresponding TyCon, so we add the quote to distinguish it here - ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc - where - pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) - then text "[tc]" - else empty - --- | Paints a picture of what a 'TyCon' represents, in broad strokes. --- This is used towards more informative error messages. -data TyConFlavour - = ClassFlavour - | TupleFlavour Boxity - | SumFlavour - | DataTypeFlavour - | NewtypeFlavour - | AbstractTypeFlavour - | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | ClosedTypeFamilyFlavour - | TypeSynonymFlavour - | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. - | PromotedDataConFlavour - deriving Eq - -instance Outputable TyConFlavour where - ppr = text . go - where - go ClassFlavour = "class" - go (TupleFlavour boxed) | isBoxed boxed = "tuple" - | otherwise = "unboxed tuple" - go SumFlavour = "unboxed sum" - go DataTypeFlavour = "data type" - go NewtypeFlavour = "newtype" - go AbstractTypeFlavour = "abstract type" - go (DataFamilyFlavour (Just _)) = "associated data family" - go (DataFamilyFlavour Nothing) = "data family" - go (OpenTypeFamilyFlavour (Just _)) = "associated type family" - go (OpenTypeFamilyFlavour Nothing) = "type family" - go ClosedTypeFamilyFlavour = "type family" - go TypeSynonymFlavour = "type synonym" - go BuiltInTypeFlavour = "built-in type" - go PromotedDataConFlavour = "promoted data constructor" - -tyConFlavour :: TyCon -> TyConFlavour -tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) - | ClassTyCon _ _ <- parent = ClassFlavour - | otherwise = case rhs of - TupleTyCon { tup_sort = sort } - -> TupleFlavour (tupleSortBoxity sort) - SumTyCon {} -> SumFlavour - DataTyCon {} -> DataTypeFlavour - NewTyCon {} -> NewtypeFlavour - AbstractTyCon {} -> AbstractTypeFlavour -tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) - = case flav of - DataFamilyTyCon{} -> DataFamilyFlavour parent - OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent - ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour - AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour - BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour -tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour -tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour -tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav - --- | Can this flavour of 'TyCon' appear unsaturated? -tcFlavourMustBeSaturated :: TyConFlavour -> Bool -tcFlavourMustBeSaturated ClassFlavour = False -tcFlavourMustBeSaturated DataTypeFlavour = False -tcFlavourMustBeSaturated NewtypeFlavour = False -tcFlavourMustBeSaturated DataFamilyFlavour{} = False -tcFlavourMustBeSaturated TupleFlavour{} = False -tcFlavourMustBeSaturated SumFlavour = False -tcFlavourMustBeSaturated AbstractTypeFlavour = False -tcFlavourMustBeSaturated BuiltInTypeFlavour = False -tcFlavourMustBeSaturated PromotedDataConFlavour = False -tcFlavourMustBeSaturated TypeSynonymFlavour = True -tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True -tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True - --- | Is this flavour of 'TyCon' an open type family or a data family? -tcFlavourIsOpen :: TyConFlavour -> Bool -tcFlavourIsOpen DataFamilyFlavour{} = True -tcFlavourIsOpen OpenTypeFamilyFlavour{} = True -tcFlavourIsOpen ClosedTypeFamilyFlavour = False -tcFlavourIsOpen ClassFlavour = False -tcFlavourIsOpen DataTypeFlavour = False -tcFlavourIsOpen NewtypeFlavour = False -tcFlavourIsOpen TupleFlavour{} = False -tcFlavourIsOpen SumFlavour = False -tcFlavourIsOpen AbstractTypeFlavour = False -tcFlavourIsOpen BuiltInTypeFlavour = False -tcFlavourIsOpen PromotedDataConFlavour = False -tcFlavourIsOpen TypeSynonymFlavour = False - -pprPromotionQuote :: TyCon -> SDoc --- Promoted data constructors already have a tick in their OccName -pprPromotionQuote tc - = case tc of - PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types - _ -> empty - -instance NamedThing TyCon where - getName = tyConName - -instance Data.Data TyCon where - -- don't traverse? - toConstr _ = abstractConstr "TyCon" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "TyCon" - -instance Binary Injectivity where - put_ bh NotInjective = putByte bh 0 - put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs - - get bh = do { h <- getByte bh - ; case h of - 0 -> return NotInjective - _ -> do { xs <- get bh - ; return (Injective xs) } } - -{- -************************************************************************ -* * - Walking over recursive TyCons -* * -************************************************************************ - -Note [Expanding newtypes and products] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When expanding a type to expose a data-type constructor, we need to be -careful about newtypes, lest we fall into an infinite loop. Here are -the key examples: - - newtype Id x = MkId x - newtype Fix f = MkFix (f (Fix f)) - newtype T = MkT (T -> T) - - Type Expansion - -------------------------- - T T -> T - Fix Maybe Maybe (Fix Maybe) - Id (Id Int) Int - Fix Id NO NO NO - -Notice that - * We can expand T, even though it's recursive. - * We can expand Id (Id Int), even though the Id shows up - twice at the outer level, because Id is non-recursive - -So, when expanding, we keep track of when we've seen a recursive -newtype at outermost level; and bail out if we see it again. - -We sometimes want to do the same for product types, so that the -strictness analyser doesn't unbox infinitely deeply. - -More precisely, we keep a *count* of how many times we've seen it. -This is to account for - data instance T (a,b) = MkT (T a) (T b) -Then (#10482) if we have a type like - T (Int,(Int,(Int,(Int,Int)))) -we can still unbox deeply enough during strictness analysis. -We have to treat T as potentially recursive, but it's still -good to be able to unwrap multiple layers. - -The function that manages all this is checkRecTc. --} - -data RecTcChecker = RC !Int (NameEnv Int) - -- The upper bound, and the number of times - -- we have encountered each TyCon - --- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. -initRecTc :: RecTcChecker -initRecTc = RC defaultRecTcMaxBound emptyNameEnv - --- | The default upper bound (100) for the number of times a 'RecTcChecker' is --- allowed to encounter each 'TyCon'. -defaultRecTcMaxBound :: Int -defaultRecTcMaxBound = 100 --- Should we have a flag for this? - --- | Change the upper bound for the number of times a 'RecTcChecker' is allowed --- to encounter each 'TyCon'. -setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker -setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts - -checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker --- Nothing => Recursion detected --- Just rec_tcs => Keep going -checkRecTc (RC bound rec_nts) tc - = case lookupNameEnv rec_nts tc_name of - Just n | n >= bound -> Nothing - | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) - Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) - where - tc_name = tyConName tc - --- | Returns whether or not this 'TyCon' is definite, or a hole --- that may be filled in at some later point. See Note [Skolem abstract data] -tyConSkolem :: TyCon -> Bool -tyConSkolem = isHoleName . tyConName - --- Note [Skolem abstract data] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Skolem abstract data arises from data declarations in an hsig file. --- --- The best analogy is to interpret the types declared in signature files as --- elaborating to universally quantified type variables; e.g., --- --- unit p where --- signature H where --- data T --- data S --- module M where --- import H --- f :: (T ~ S) => a -> b --- f x = x --- --- elaborates as (with some fake structural types): --- --- p :: forall t s. { f :: forall a b. t ~ s => a -> b } --- p = { f = \x -> x } -- ill-typed --- --- It is clear that inside p, t ~ s is not provable (and --- if we tried to write a function to cast t to s, that --- would not work), but if we call p @Int @Int, clearly Int ~ Int --- is provable. The skolem variables are all distinct from --- one another, but we can't make assumptions like "f is --- inaccessible", because the skolem variables will get --- instantiated eventually! --- --- Skolem abstractness can apply to "non-abstract" data as well): --- --- unit p where --- signature H1 where --- data T = MkT --- signature H2 where --- data T = MkT --- module M where --- import qualified H1 --- import qualified H2 --- f :: (H1.T ~ H2.T) => a -> b --- f x = x --- --- This is why the test is on the original name of the TyCon, --- not whether it is abstract or not. diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot deleted file mode 100644 --- a/compiler/types/TyCon.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module TyCon where - -import GhcPrelude - -data TyCon - -isTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs deleted file mode 100644 --- a/compiler/types/Type.hs +++ /dev/null @@ -1,3229 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1998 --- --- Type - public interface - -{-# LANGUAGE CPP, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Main functions for manipulating types and type-related things -module Type ( - -- Note some of this is just re-exports from TyCon.. - - -- * Main data types representing Types - -- $type_classification - - -- $representation_types - TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, - KnotTied, - - -- ** Constructing and deconstructing types - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, - getCastedTyVar_maybe, tyVarKind, varType, - - mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, - - mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, - splitFunTy, splitFunTy_maybe, - splitFunTys, funResultTy, funArgTy, - - mkTyConApp, mkTyConTy, - tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, - tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, - tcSplitTyConApp_maybe, - splitListTyConApp_maybe, - repSplitTyConApp_maybe, - - mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, - mkSpecForAllTy, mkSpecForAllTys, - mkVisForAllTys, mkTyCoInvForAllTy, - mkInvForAllTy, mkInvForAllTys, - splitForAllTys, splitForAllTysSameVis, - splitForAllVarBndrs, - splitForAllTy_maybe, splitForAllTy, - splitForAllTy_ty_maybe, splitForAllTy_co_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, - mkTyConBindersPreferAnon, - mkPiTy, mkPiTys, - mkLamType, mkLamTypes, - piResultTy, piResultTys, - applyTysX, dropForAlls, - mkFamilyTyConApp, - buildSynTyCon, - - mkNumLitTy, isNumLitTy, - mkStrLitTy, isStrLitTy, - isLitTy, - - isPredTy, - - getRuntimeRep_maybe, kindRep_maybe, kindRep, - - mkCastTy, mkCoercionTy, splitCastTy_maybe, - discardCast, - - userTypeError_maybe, pprUserTypeErrorTy, - - coAxNthLHS, - stripCoercionTy, - - splitPiTysInvisible, splitPiTysInvisibleN, - invisibleTyBndrCount, - filterOutInvisibleTypes, filterOutInferredTypes, - partitionInvisibleTypes, partitionInvisibles, - tyConArgFlags, appTyArgFlags, - synTyConResKind, - - modifyJoinResTy, setJoinResTy, - - -- ** Analyzing types - TyCoMapper(..), mapType, mapCoercion, - TyCoFolder(..), foldTyCo, - - -- (Newtypes) - newTyConInstRhs, - - -- ** Binders - sameVis, - mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinders, - mkAnonBinder, - isAnonTyCoBinder, - binderVar, binderVars, binderType, binderArgFlag, - tyCoBinderType, tyCoBinderVar_maybe, - tyBinderType, - binderRelevantType_maybe, - isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, - isInvisibleBinder, isNamedBinder, - tyConBindersTyCoBinders, - - -- ** Common type constructors - funTyCon, - - -- ** Predicates on types - isTyVarTy, isFunTy, isCoercionTy, - isCoercionTy_maybe, isForAllTy, - isForAllTy_ty, isForAllTy_co, - isPiTy, isTauTy, isFamFreeTy, - isCoVarType, - - isValidJoinPointType, - tyConAppNeedsKindSig, - - -- *** Levity and boxity - isLiftedType_maybe, - isLiftedTypeKind, isUnliftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, - isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, - isAlgType, isDataFamilyAppType, - isPrimitiveType, isStrictType, - isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, - dropRuntimeRepArgs, - getRuntimeRep, - - -- * Main data types representing Kinds - Kind, - - -- ** Finding the kind of a type - typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, - tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, - tcIsRuntimeTypeKind, - - -- ** Common Kind - liftedTypeKind, - - -- * Type free variables - tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, - coVarsOfType, - coVarsOfTypes, - - noFreeVarsOfType, - splitVisVarsOfType, splitVisVarsOfTypes, - expandTypeSynonyms, - typeSize, occCheckExpand, - - -- ** Closing over kinds - closeOverKindsDSet, closeOverKindsList, - closeOverKinds, - - -- * Well-scoped lists of variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - - -- * Type comparison - eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, - nonDetCmpTypesX, nonDetCmpTc, - eqVarBndrs, - - -- * Forcing evaluation of types - seqType, seqTypes, - - -- * Other views onto Types - coreView, tcView, - - tyConsOfType, - - -- * Main type substitution data types - TvSubstEnv, -- Representation widely visible - TCvSubst(..), -- Representation visible to a few friends - - -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - - mkTCvSubst, zipTvSubst, mkTvSubstPrs, - zipTCvSubst, - notElemTCvSubst, - getTvSubstEnv, setTvSubstEnv, - zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendCvSubst, - extendTvSubst, extendTvSubstBinderAndInScope, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - extendTvSubstWithClone, - extendTCvSubstWithClone, - isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, - isEmptyTCvSubst, unionTCvSubst, - - -- ** Performing substitution on types and kinds - substTy, substTys, substTyWith, substTysWith, substTheta, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, - substVarBndr, substVarBndrs, - cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyKind, - tidyTyCoVarBinder, tidyTyCoVarBinders, - - -- * Kinds - isConstraintKindCon, - classifiesTypeWithValues, - isKindLevPoly - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes - --- We import the representation and primitive functions from TyCoRep. --- Many things are reexported, but not the representation! - -import TyCoRep -import TyCoSubst -import TyCoTidy -import TyCoFVs - --- friends: -import Var -import VarEnv -import VarSet -import UniqSet - -import TyCon -import TysPrim -import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind - , typeSymbolKind, liftedTypeKind - , liftedTypeKindTyCon - , constraintKind ) -import Name( Name ) -import PrelNames -import CoAxiom -import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo - , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo - , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo - , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo - , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo - , decomposePiCos, coercionKind, coercionLKind - , coercionRKind, coercionType - , isReflexiveCo, seqCo ) - --- others -import Util -import FV -import Outputable -import FastString -import Pair -import ListSetOps -import Unique ( nonDetCmpUnique ) - -import Maybes ( orElse ) -import Data.Maybe ( isJust ) -import Control.Monad ( guard ) - --- $type_classification --- #type_classification# --- --- Types are one of: --- --- [Unboxed] Iff its representation is other than a pointer --- Unboxed types are also unlifted. --- --- [Lifted] Iff it has bottom as an element. --- Closures always have lifted types: i.e. any --- let-bound identifier in Core must have a lifted --- type. Operationally, a lifted object is one that --- can be entered. --- Only lifted types may be unified with a type variable. --- --- [Algebraic] Iff it is a type with one or more constructors, whether --- declared with @data@ or @newtype@. --- An algebraic type is one that can be deconstructed --- with a case expression. This is /not/ the same as --- lifted types, because we also include unboxed --- tuples in this classification. --- --- [Data] Iff it is a type declared with @data@, or a boxed tuple. --- --- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. --- --- Currently, all primitive types are unlifted, but that's not necessarily --- the case: for example, @Int@ could be primitive. --- --- Some primitive types are unboxed, such as @Int#@, whereas some are boxed --- but unlifted (such as @ByteArray#@). The only primitive types that we --- classify as algebraic are the unboxed tuples. --- --- Some examples of type classifications that may make this a bit clearer are: --- --- @ --- Type primitive boxed lifted algebraic --- ----------------------------------------------------------------------------- --- Int# Yes No No No --- ByteArray# Yes Yes No No --- (\# a, b \#) Yes No No Yes --- (\# a | b \#) Yes No No Yes --- ( a, b ) No Yes Yes Yes --- [a] No Yes Yes Yes --- @ - --- $representation_types --- A /source type/ is a type that is a separate type as far as the type checker is --- concerned, but which has a more low-level representation as far as Core-to-Core --- passes and the rest of the back end is concerned. --- --- You don't normally have to worry about this, as the utility functions in --- this module will automatically convert a source into a representation type --- if they are spotted, to the best of its abilities. If you don't want this --- to happen, use the equivalent functions from the "TcType" module. - -{- -************************************************************************ -* * - Type representation -* * -************************************************************************ - -Note [coreView vs tcView] -~~~~~~~~~~~~~~~~~~~~~~~~~ -So far as the typechecker is concerned, 'Constraint' and 'TYPE -LiftedRep' are distinct kinds. - -But in Core these two are treated as identical. - -We implement this by making 'coreView' convert 'Constraint' to 'TYPE -LiftedRep' on the fly. The function tcView (used in the type checker) -does not do this. - -See also #11715, which tracks removing this inconsistency. - --} - --- | Gives the typechecker view of a type. This unwraps synonyms but --- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into --- TYPE LiftedRep. Returns Nothing if no unwrapping happens. --- See also Note [coreView vs tcView] -{-# INLINE tcView #-} -tcView :: Type -> Maybe Type -tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - -- The free vars of 'rhs' should all be bound by 'tenv', so it's - -- ok to use 'substTy' here. - -- See also Note [The substitution invariant] in TyCoSubst. - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! -tcView _ = Nothing - -{-# INLINE coreView #-} -coreView :: Type -> Maybe Type --- ^ This function Strips off the /top layer only/ of a type synonym --- application (if any) its underlying representation type. --- Returns Nothing if there is nothing to look through. --- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. --- --- By being non-recursive and inlined, this case analysis gets efficiently --- joined onto the case analysis that the caller is already doing -coreView ty@(TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - -- This equation is exactly like tcView - - -- At the Core level, Constraint = Type - -- See Note [coreView vs tcView] - | isConstraintKindCon tc - = ASSERT2( null tys, ppr ty ) - Just liftedTypeKind - -coreView _ = Nothing - ------------------------------------------------ -expandTypeSynonyms :: Type -> Type --- ^ Expand out all type synonyms. Actually, it'd suffice to expand out --- just the ones that discard type variables (e.g. type Funny a = Int) --- But we don't know which those are currently, so we just expand all. --- --- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, --- not in the kinds of any TyCon or TyVar mentioned in the type. --- --- Keep this synchronized with 'synonymTyConsOfType' -expandTypeSynonyms ty - = go (mkEmptyTCvSubst in_scope) ty - where - in_scope = mkInScopeSet (tyCoVarsOfType ty) - - go subst (TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys - = let subst' = mkTvSubst in_scope (mkVarEnv tenv) - -- Make a fresh substitution; rhs has nothing to - -- do with anything that has happened so far - -- NB: if you make changes here, be sure to build an - -- /idempotent/ substitution, even in the nested case - -- type T a b = a -> b - -- type S x y = T y x - -- (#11665) - in mkAppTys (go subst' rhs) tys' - | otherwise - = TyConApp tc expanded_tys - where - expanded_tys = (map (go subst) tys) - - go _ (LitTy l) = LitTy l - go subst (TyVarTy tv) = substTyVar subst tv - go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst ty@(FunTy _ arg res) - = ty { ft_arg = go subst arg, ft_res = go subst res } - go subst (ForAllTy (Bndr tv vis) t) - = let (subst', tv') = substVarBndrUsing go subst tv in - ForAllTy (Bndr tv' vis) (go subst' t) - go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) - go subst (CoercionTy co) = mkCoercionTy (go_co subst co) - - go_mco _ MRefl = MRefl - go_mco subst (MCo co) = MCo (go_co subst co) - - go_co subst (Refl ty) - = mkNomReflCo (go subst ty) - go_co subst (GRefl r ty mco) - = mkGReflCo r (go subst ty) (go_mco subst mco) - -- NB: coercions are always expanded upon creation - go_co subst (TyConAppCo r tc args) - = mkTyConAppCo r tc (map (go_co subst) args) - go_co subst (AppCo co arg) - = mkAppCo (go_co subst co) (go_co subst arg) - go_co subst (ForAllCo tv kind_co co) - = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in - mkForAllCo tv' kind_co' (go_co subst' co) - go_co subst (FunCo r co1 co2) - = mkFunCo r (go_co subst co1) (go_co subst co2) - go_co subst (CoVarCo cv) - = substCoVar subst cv - go_co subst (AxiomInstCo ax ind args) - = mkAxiomInstCo ax ind (map (go_co subst) args) - go_co subst (UnivCo p r t1 t2) - = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) - go_co subst (SymCo co) - = mkSymCo (go_co subst co) - go_co subst (TransCo co1 co2) - = mkTransCo (go_co subst co1) (go_co subst co2) - go_co subst (NthCo r n co) - = mkNthCo r n (go_co subst co) - go_co subst (LRCo lr co) - = mkLRCo lr (go_co subst co) - go_co subst (InstCo co arg) - = mkInstCo (go_co subst co) (go_co subst arg) - go_co subst (KindCo co) - = mkKindCo (go_co subst co) - go_co subst (SubCo co) - = mkSubCo (go_co subst co) - go_co subst (AxiomRuleCo ax cs) - = AxiomRuleCo ax (map (go_co subst) cs) - go_co _ (HoleCo h) - = pprPanic "expandTypeSynonyms hit a hole" (ppr h) - - go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) - go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) - go_prov _ p@(PluginProv _) = p - - -- the "False" and "const" are to accommodate the type of - -- substForAllCoBndrUsing, which is general enough to - -- handle coercion optimization (which sometimes swaps the - -- order of a coercion) - go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst - - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @kindRep * = LiftedRep@; Panics if this is not possible. --- Treats * and Constraint as the same -kindRep :: HasDebugCallStack => Kind -> Type -kindRep k = case kindRep_maybe k of - Just r -> r - Nothing -> pprPanic "kindRep" (ppr k) - --- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. --- For example, @kindRep_maybe * = Just LiftedRep@ --- Returns 'Nothing' if the kind is not of form (TYPE rr) --- Treats * and Constraint as the same -kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type -kindRep_maybe kind - | Just kind' <- coreView kind = kindRep_maybe kind' - | TyConApp tc [arg] <- kind - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing - --- | This version considers Constraint to be the same as *. Returns True --- if the argument is equivalent to Type/Constraint and False otherwise. --- See Note [Kind Constraint and kind Type] -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - -isLiftedRuntimeRep :: Type -> Bool --- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep --- False of type variables (a :: RuntimeRep) --- and of other reps e.g. (IntRep :: RuntimeRep) -isLiftedRuntimeRep rep - | Just rep' <- coreView rep = isLiftedRuntimeRep rep' - | TyConApp rr_tc args <- rep - , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True - | otherwise = False - --- | Returns True if the kind classifies unlifted types and False otherwise. --- Note that this returns False for levity-polymorphic kinds, which may --- be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep - Nothing -> False - -isUnliftedRuntimeRep :: Type -> Bool --- True of definitely-unlifted RuntimeReps --- False of (LiftedRep :: RuntimeRep) --- and of variables (a :: RuntimeRep) -isUnliftedRuntimeRep rep - | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' - | TyConApp rr_tc _ <- rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] - = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) - -- Avoid searching all the unlifted RuntimeRep type cons - -- In the RuntimeRep data type, only LiftedRep is lifted - -- But be careful of type families (F tys) :: RuntimeRep - | otherwise {- Variables, applications -} - = False - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' -isRuntimeRepTy (TyConApp tc args) - | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True -isRuntimeRepTy _ = False - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - - -{- ********************************************************************* -* * - mapType -* * -************************************************************************ - -These functions do a map-like operation over types, performing some operation -on all variables and binding sites. Primarily used for zonking. - -Note [Efficiency for mapCoercion ForAllCo case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. -It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches -the left-hand kind of the coercion. This is convenient lots of the time, but -not when mapping a function over a coercion. - -The problem is that tcm_tybinder will affect the TyCoVar's kind and -mapCoercion will affect the Coercion, and we hope that the results will be -the same. Even if they are the same (which should generally happen with -correct algorithms), then there is an efficiency issue. In particular, -this problem seems to make what should be a linear algorithm into a potentially -exponential one. But it's only going to be bad in the case where there's -lots of foralls in the kinds of other foralls. Like this: - - forall a : (forall b : (forall c : ...). ...). ... - -This construction seems unlikely. So we'll do the inefficient, easy way -for now. - -Note [Specialising mappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These INLINABLE pragmas are indispensable. mapType/mapCoercion are used -to implement zonking, and it's vital that they get specialised to the TcM -monad. This specialisation happens automatically (that is, without a -SPECIALISE pragma) as long as the definitions are INLINABLE. For example, -this one change made a 20% allocation difference in perf/compiler/T5030. - --} - --- | This describes how a "map" operation over a type/coercion should behave -data TyCoMapper env m - = TyCoMapper - { tcm_tyvar :: env -> TyVar -> m Type - , tcm_covar :: env -> CoVar -> m Coercion - , tcm_hole :: env -> CoercionHole -> m Coercion - -- ^ What to do with coercion holes. - -- See Note [Coercion holes] in TyCoRep. - - , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) - -- ^ The returned env is used in the extended scope - - , tcm_tycon :: TyCon -> m TyCon - -- ^ This is used only for TcTyCons - -- a) To zonk TcTyCons - -- b) To turn TcTyCons into TyCons. - -- See Note [Type checking recursive type and class declarations] - -- in TcTyClsDecls - } - -{-# INLINABLE mapType #-} -- See Note [Specialising mappers] -mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type -mapType mapper@(TyCoMapper { tcm_tyvar = tyvar - , tcm_tycobinder = tycobinder - , tcm_tycon = tycon }) - env ty - = go ty - where - go (TyVarTy tv) = tyvar env tv - go (AppTy t1 t2) = mkAppTy <$> go t1 <*> go t2 - go ty@(LitTy {}) = return ty - go (CastTy ty co) = mkCastTy <$> go ty <*> mapCoercion mapper env co - go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co - - go ty@(FunTy _ arg res) - = do { arg' <- go arg; res' <- go res - ; return (ty { ft_arg = arg', ft_res = res' }) } - - go ty@(TyConApp tc tys) - | isTcTyCon tc - = do { tc' <- tycon tc - ; mkTyConApp tc' <$> mapM go tys } - - -- Not a TcTyCon - | null tys -- Avoid allocation in this very - = return ty -- common case (E.g. Int, LiftedRep etc) - - | otherwise - = mkTyConApp tc <$> mapM go tys - - go (ForAllTy (Bndr tv vis) inner) - = do { (env', tv') <- tycobinder env tv vis - ; inner' <- mapType mapper env' inner - ; return $ ForAllTy (Bndr tv' vis) inner' } - -{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] -mapCoercion :: Monad m - => TyCoMapper env m -> env -> Coercion -> m Coercion -mapCoercion mapper@(TyCoMapper { tcm_covar = covar - , tcm_hole = cohole - , tcm_tycobinder = tycobinder - , tcm_tycon = tycon }) - env co - = go co - where - go_mco MRefl = return MRefl - go_mco (MCo co) = MCo <$> (go co) - - go (Refl ty) = Refl <$> mapType mapper env ty - go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco) - go (TyConAppCo r tc args) - = do { tc' <- if isTcTyCon tc - then tycon tc - else return tc - ; mkTyConAppCo r tc' <$> mapM go args } - go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2 - go (ForAllCo tv kind_co co) - = do { kind_co' <- go kind_co - ; (env', tv') <- tycobinder env tv Inferred - ; co' <- mapCoercion mapper env' co - ; return $ mkForAllCo tv' kind_co' co' } - -- See Note [Efficiency for mapCoercion ForAllCo case] - go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 - go (CoVarCo cv) = covar env cv - go (AxiomInstCo ax i args) - = mkAxiomInstCo ax i <$> mapM go args - go (HoleCo hole) = cohole env hole - go (UnivCo p r t1 t2) - = mkUnivCo <$> go_prov p <*> pure r - <*> mapType mapper env t1 <*> mapType mapper env t2 - go (SymCo co) = mkSymCo <$> go co - go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2 - go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos - go (NthCo r i co) = mkNthCo r i <$> go co - go (LRCo lr co) = mkLRCo lr <$> go co - go (InstCo co arg) = mkInstCo <$> go co <*> go arg - go (KindCo co) = mkKindCo <$> go co - go (SubCo co) = mkSubCo <$> go co - - go_prov (PhantomProv co) = PhantomProv <$> go co - go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co - go_prov p@(PluginProv _) = return p - - -{- -************************************************************************ -* * -\subsection{Constructor-specific functions} -* * -************************************************************************ - - ---------------------------------------------------------------------- - TyVarTy - ~~~~~~~ --} - --- | Attempts to obtain the type variable underlying a 'Type', and panics with the --- given message if this is not a type variable type. See also 'getTyVar_maybe' -getTyVar :: String -> Type -> TyVar -getTyVar msg ty = case getTyVar_maybe ty of - Just tv -> tv - Nothing -> panic ("getTyVar: " ++ msg) - -isTyVarTy :: Type -> Bool -isTyVarTy ty = isJust (getTyVar_maybe ty) - --- | Attempts to obtain the type variable underlying a 'Type' -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' - | otherwise = repGetTyVar_maybe ty - --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind ty -getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' -getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -getCastedTyVar_maybe (TyVarTy tv) - = Just (tv, mkReflCo Nominal (tyVarKind tv)) -getCastedTyVar_maybe _ = Nothing - --- | Attempts to obtain the type variable underlying a 'Type', without --- any expansion -repGetTyVar_maybe :: Type -> Maybe TyVar -repGetTyVar_maybe (TyVarTy tv) = Just tv -repGetTyVar_maybe _ = Nothing - -{- ---------------------------------------------------------------------- - AppTy - ~~~~~ -We need to be pretty careful with AppTy to make sure we obey the -invariant that a TyConApp is always visibly so. mkAppTy maintains the -invariant: use it. - -Note [Decomposing fat arrow c=>t] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can we unify (a b) with (Eq a => ty)? If we do so, we end up with -a partial application like ((=>) Eq a) which doesn't make sense in -source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). -Here's an example (#9858) of how you might do it: - i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep - i p = typeRep p - - j = i (Proxy :: Proxy (Eq Int => Int)) -The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, -but suppose we want that. But then in the call to 'i', we end -up decomposing (Eq Int => Int), and we definitely don't want that. - -This really only applies to the type checker; in Core, '=>' and '->' -are the same, as are 'Constraint' and '*'. But for now I've put -the test in repSplitAppTy_maybe, which applies throughout, because -the other calls to splitAppTy are in Unify, which is also used by -the type checker (e.g. when matching type-function equations). - --} - --- | Applies a type to another, as in e.g. @k a@ -mkAppTy :: Type -> Type -> Type - -- See Note [Respecting definitional equality], invariant (EQ1). -mkAppTy (CastTy fun_ty co) arg_ty - | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] - = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co - -mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) -mkAppTy ty1 ty2 = AppTy ty1 ty2 - -- Note that the TyConApp could be an - -- under-saturated type synonym. GHC allows that; e.g. - -- type Foo k = k a -> k a - -- type Id x = x - -- foo :: Foo Id -> Foo Id - -- - -- Here Id is partially applied in the type sig for Foo, - -- but once the type synonyms are expanded all is well - -- - -- Moreover in TcHsTypes.tcInferApps we build up a type - -- (T t1 t2 t3) one argument at a type, thus forming - -- (T t1), (T t1 t2), etc - -mkAppTys :: Type -> [Type] -> Type -mkAppTys ty1 [] = ty1 -mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy - -- Why do this? See (EQ1) of - -- Note [Respecting definitional equality] - -- in TyCoRep - = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers - where - (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys - (args_to_cast, leftovers) = splitAtList arg_cos arg_tys - casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos -mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) -mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 - -------------- -splitAppTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempt to take a type application apart, whether it is a --- function, type constructor, or plain type application. Note --- that type family applications are NEVER unsaturated by this! -splitAppTy_maybe ty | Just ty' <- coreView ty - = splitAppTy_maybe ty' -splitAppTy_maybe ty = repSplitAppTy_maybe ty - -------------- -repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that --- any Core view stuff is already done -repSplitAppTy_maybe (FunTy _ ty1 ty2) - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -repSplitAppTy_maybe (AppTy ty1 ty2) - = Just (ty1, ty2) - -repSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! - -repSplitAppTy_maybe _other = Nothing - --- This one doesn't break apart (c => t). --- See Note [Decomposing fat arrow c=>t] --- Defined here to avoid module loops between Unify and TcType. -tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that --- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) - | InvisArg <- af - = Nothing -- See Note [Decomposing fat arrow c=>t] - - | otherwise - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcRepSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! -tcRepSplitAppTy_maybe _other = Nothing - -------------- -splitAppTy :: Type -> (Type, Type) --- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', --- and panics if this is not possible -splitAppTy ty = case splitAppTy_maybe ty of - Just pr -> pr - Nothing -> panic "splitAppTy" - -------------- -splitAppTys :: Type -> (Type, [Type]) --- ^ Recursively splits a type as far as is possible, leaving a residual --- type being applied to and the type arguments applied to it. Never fails, --- even if that means returning an empty list of type applications. -splitAppTys ty = split ty ty [] - where - split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args - split _ (AppTy ty arg) args = split ty ty (arg:args) - split _ (TyConApp tc tc_args) args - = let -- keep type families saturated - n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy _ ty1 ty2) args - = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split orig_ty _ args = (orig_ty, args) - --- | Like 'splitAppTys', but doesn't look through type synonyms -repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -repSplitAppTys ty = split ty [] - where - split (AppTy ty arg) args = split ty (arg:args) - split (TyConApp tc tc_args) args - = let n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split (FunTy _ ty1 ty2) args - = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split ty args = (ty, args) - -{- - LitTy - ~~~~~ --} - -mkNumLitTy :: Integer -> Type -mkNumLitTy n = LitTy (NumTyLit n) - --- | Is this a numeric literal. We also look through type synonyms. -isNumLitTy :: Type -> Maybe Integer -isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 -isNumLitTy (LitTy (NumTyLit n)) = Just n -isNumLitTy _ = Nothing - -mkStrLitTy :: FastString -> Type -mkStrLitTy s = LitTy (StrTyLit s) - --- | Is this a symbol literal. We also look through type synonyms. -isStrLitTy :: Type -> Maybe FastString -isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 -isStrLitTy (LitTy (StrTyLit s)) = Just s -isStrLitTy _ = Nothing - --- | Is this a type literal (symbol or numeric). -isLitTy :: Type -> Maybe TyLit -isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 -isLitTy (LitTy l) = Just l -isLitTy _ = Nothing - --- | Is this type a custom user error? --- If so, give us the kind and the error message. -userTypeError_maybe :: Type -> Maybe Type -userTypeError_maybe t - = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - - ; guard (tyConName tc == errorMessageTypeErrorFamName) - ; return msg } - --- | Render a type corresponding to a user type error into a SDoc. -pprUserTypeErrorTy :: Type -> SDoc -pprUserTypeErrorTy ty = - case splitTyConApp_maybe ty of - - -- Text "Something" - Just (tc,[txt]) - | tyConName tc == typeErrorTextDataConName - , Just str <- isStrLitTy txt -> ftext str - - -- ShowType t - Just (tc,[_k,t]) - | tyConName tc == typeErrorShowTypeDataConName -> ppr t - - -- t1 :<>: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorAppendDataConName -> - pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 - - -- t1 :$$: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorVAppendDataConName -> - pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 - - -- An unevaluated type function - _ -> ppr ty - - - - -{- ---------------------------------------------------------------------- - FunTy - ~~~~~ - -Note [Representation of function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Functions (e.g. Int -> Char) can be thought of as being applications -of funTyCon (known in Haskell surface syntax as (->)), - - (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> Type - -However, for efficiency's sake we represent saturated applications of (->) -with FunTy. For instance, the type, - - (->) r1 r2 a b - -is equivalent to, - - FunTy (Anon a) b - -Note how the RuntimeReps are implied in the FunTy representation. For this -reason we must be careful when recontructing the TyConApp representation (see, -for instance, splitTyConApp_maybe). - -In the compiler we maintain the invariant that all saturated applications of -(->) are represented with FunTy. - -See #11714. --} - -splitFunTy :: Type -> (Type, Type) --- ^ Attempts to extract the argument and result types from a type, and --- panics if that is not possible. See also 'splitFunTy_maybe' -splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (FunTy _ arg res) = (arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) - -splitFunTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempts to extract the argument and result types from a type -splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) -splitFunTy_maybe _ = Nothing - -splitFunTys :: Type -> ([Type], Type) -splitFunTys ty = split [] ty ty - where - split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (FunTy _ arg res) = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) - -funResultTy :: Type -> Type --- ^ Extract the function result type and panic if that is not possible -funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy { ft_res = res }) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) - -funArgTy :: Type -> Type --- ^ Extract the function argument type and panic if that is not possible -funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy { ft_arg = arg }) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) - --- ^ Just like 'piResultTys' but for a single argument --- Try not to iterate 'piResultTy', because it's inefficient to substitute --- one variable at a time; instead use 'piResultTys" -piResultTy :: HasDebugCallStack => Type -> Type -> Type -piResultTy ty arg = case piResultTy_maybe ty arg of - Just res -> res - Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) - -piResultTy_maybe :: Type -> Type -> Maybe Type --- We don't need a 'tc' version, because --- this function behaves the same for Type and Constraint -piResultTy_maybe ty arg - | Just ty' <- coreView ty = piResultTy_maybe ty' arg - - | FunTy { ft_res = res } <- ty - = Just res - - | ForAllTy (Bndr tv _) res <- ty - = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTCvSubst empty_subst tv arg) res) - - | otherwise - = Nothing - --- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) --- where f :: f_ty --- 'piResultTys' is interesting because: --- 1. 'f_ty' may have more for-alls than there are args --- 2. Less obviously, it may have fewer for-alls --- For case 2. think of: --- piResultTys (forall a.a) [forall b.b, Int] --- This really can happen, but only (I think) in situations involving --- undefined. For example: --- undefined :: forall a. a --- Term: undefined @(forall b. b->b) @Int --- This term should have type (Int -> Int), but notice that --- there are more type args than foralls in 'undefined's type. - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint - --- This is a heavily used function (e.g. from typeKind), --- so we pay attention to efficiency, especially in the special case --- where there are no for-alls so we are just dropping arrows from --- a function type/kind. -piResultTys :: HasDebugCallStack => Type -> [Type] -> Type -piResultTys ty [] = ty -piResultTys ty orig_args@(arg:args) - | Just ty' <- coreView ty - = piResultTys ty' orig_args - - | FunTy { ft_res = res } <- ty - = piResultTys res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst init_subst tv arg) res args - - | otherwise - = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) - where - init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - - go :: TCvSubst -> Type -> [Type] -> Type - go subst ty [] = substTyUnchecked subst ty - - go subst ty all_args@(arg:args) - | Just ty' <- coreView ty - = go subst ty' all_args - - | FunTy { ft_res = res } <- ty - = go subst res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst subst tv arg) res args - - | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] - = go init_subst - (substTy subst ty) - all_args - - | otherwise - = -- We have not run out of arguments, but the function doesn't - -- have the right kind to apply to them; so panic. - -- Without the explicit isEmptyVarEnv test, an ill-kinded type - -- would give an infinite loop, which is very unhelpful - -- c.f. #15473 - pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) - -applyTysX :: [TyVar] -> Type -> [Type] -> Type --- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys --- Assumes that (/\tvs. body_ty) is closed -applyTysX tvs body_ty arg_tys - = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) - ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) - mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) - (drop n_tvs arg_tys) - where - pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] - n_tvs = length tvs - - - -{- Note [Care with kind instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - T :: forall k. k -and we are finding the kind of - T (forall b. b -> b) * Int -Then - T (forall b. b->b) :: k[ k :-> forall b. b->b] - :: forall b. b -> b -So - T (forall b. b->b) * :: (b -> b)[ b :-> *] - :: * -> * - -In other words we must instantiate the forall! - -Similarly (#15428) - S :: forall k f. k -> f k -and we are finding the kind of - S * (* ->) Int Bool -We have - S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] - :: * -> * -> * -So again we must instantiate. - -The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. - --------------------------------------- -Note [mkTyConApp and Type] - -Whilst benchmarking it was observed in #17292 that GHC allocated a lot -of `TyConApp` constructors. Upon further inspection a large number of these -TyConApp constructors were all duplicates of `Type` applied to no arguments. - -``` -(From a sample of 100000 TyConApp closures) -0x45f3523 - 28732 - `Type` -0x420b840702 - 9629 - generic type constructors -0x42055b7e46 - 9596 -0x420559b582 - 9511 -0x420bb15a1e - 9509 -0x420b86c6ba - 9501 -0x42055bac1e - 9496 -0x45e68fd - 538 - `TYPE ...` -``` - -Therefore in `mkTyConApp` we have a special case for `Type` to ensure that -only one `TyConApp 'Type []` closure is allocated during the course of -compilation. In order to avoid a potentially expensive series of checks in -`mkTyConApp` only this egregious case is special cased at the moment. - - ---------------------------------------------------------------------- - TyConApp - ~~~~~~~~ --} - --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon - , [_rep1,_rep2,ty1,ty2] <- tys - -- The FunTyCon (->) is always a visible one - = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } - -- Note [mkTyConApp and Type] - | tycon == liftedTypeKindTyCon - = ASSERT2( null tys, ppr tycon $$ ppr tys ) - liftedTypeKindTyConApp - | otherwise - = TyConApp tycon tys - --- This is a single, global definition of the type `Type` --- Defined here so it is only allocated once. --- See Note [mkTyConApp and Type] -liftedTypeKindTyConApp :: Type -liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] - --- splitTyConApp "looks through" synonyms, because they don't --- mean a distinct type, but all other type-constructor applications --- including functions are returned as Just .. - --- | Retrieve the tycon heading this type, if there is one. Does /not/ --- look through synonyms. -tyConAppTyConPicky_maybe :: Type -> Maybe TyCon -tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc -tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon -tyConAppTyConPicky_maybe _ = Nothing - - --- | The same as @fst . splitTyConApp@ -tyConAppTyCon_maybe :: Type -> Maybe TyCon -tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' -tyConAppTyCon_maybe (TyConApp tc _) = Just tc -tyConAppTyCon_maybe (FunTy {}) = Just funTyCon -tyConAppTyCon_maybe _ = Nothing - -tyConAppTyCon :: Type -> TyCon -tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) - --- | The same as @snd . splitTyConApp@ -tyConAppArgs_maybe :: Type -> Maybe [Type] -tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' -tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (FunTy _ arg res) - | Just rep1 <- getRuntimeRep_maybe arg - , Just rep2 <- getRuntimeRep_maybe res - = Just [rep1, rep2, arg, res] -tyConAppArgs_maybe _ = Nothing - -tyConAppArgs :: Type -> [Type] -tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) - -tyConAppArgN :: Int -> Type -> Type --- Executing Nth -tyConAppArgN n ty - = case tyConAppArgs_maybe ty of - Just tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n - Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor. Panics if that is not possible. --- See also 'splitTyConApp_maybe' -splitTyConApp :: Type -> (TyCon, [Type]) -splitTyConApp ty = case splitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' -splitTyConApp_maybe ty = repSplitTyConApp_maybe ty - --- | Split a type constructor application into its type constructor and --- applied types. Note that this may fail in the case of a 'FunTy' with an --- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind --- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your --- type before using this function. --- --- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) --- Defined here to avoid module loops between Unify and TcType. -tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' -tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty - -------------------- -repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) --- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. --- --- Moreover, for a FunTy, it only succeeds if the argument types --- have enough info to extract the runtime-rep arguments that --- the funTyCon requires. This will usually be true; --- but may be temporarily false during canonicalization: --- see Note [FunTy and decomposing tycon applications] in TcCanonical --- -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy _ arg res) - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [arg_rep, res_rep, arg, res]) -repSplitTyConApp_maybe _ = Nothing - -------------------- --- | Attempts to tease a list type apart and gives the type of the elements if --- successful (looks through type synonyms) -splitListTyConApp_maybe :: Type -> Maybe Type -splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of - Just (tc,[e]) | tc == listTyCon -> Just e - _other -> Nothing - -nextRole :: Type -> Role -nextRole ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , let num_tys = length tys - , num_tys < tyConArity tc - = tyConRoles tc `getNth` num_tys - - | otherwise - = Nominal - -newTyConInstRhs :: TyCon -> [Type] -> Type --- ^ Unwrap one 'layer' of newtype on a type constructor and its --- arguments, using an eta-reduced version of the @newtype@ if possible. --- This requires tys to have at least @newTyConInstArity tycon@ elements. -newTyConInstRhs tycon tys - = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) - applyTysX tvs rhs tys - where - (tvs, rhs) = newTyConEtadRhs tycon - -{- ---------------------------------------------------------------------- - CastTy - ~~~~~~ -A casted type has its *kind* casted into something new. --} - -splitCastTy_maybe :: Type -> Maybe (Type, Coercion) -splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' -splitCastTy_maybe (CastTy ty co) = Just (ty, co) -splitCastTy_maybe _ = Nothing - --- | Make a 'CastTy'. The Coercion must be nominal. Checks the --- Coercion for reflexivity, dropping it if it's reflexive. --- See Note [Respecting definitional equality] in TyCoRep -mkCastTy :: Type -> Coercion -> Type -mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note --- NB: Do the slow check here. This is important to keep the splitXXX --- functions working properly. Otherwise, we may end up with something --- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) --- fails under splitFunTy_maybe. This happened with the cheaper check --- in test dependent/should_compile/dynamic-paper. - -mkCastTy (CastTy ty co1) co2 - -- (EQ3) from the Note - = mkCastTy ty (co1 `mkTransCo` co2) - -- call mkCastTy again for the reflexivity check - -mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co - -- (EQ4) from the Note - | isTyVar tv - , let fvs = tyCoVarsOfCo co - = -- have to make sure that pushing the co in doesn't capture the bound var! - if tv `elemVarSet` fvs - then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) - (subst, tv') = substVarBndr empty_subst tv - in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) - else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) - -mkCastTy ty co = CastTy ty co - -tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] --- Return the tyConBinders in TyCoBinder form -tyConBindersTyCoBinders = map to_tyb - where - to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) - to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) - --- | Drop the cast on a type, if any. If there is no --- cast, just return the original type. This is rarely what --- you want. The CastTy data constructor (in TyCoRep) has the --- invariant that another CastTy is not inside. See the --- data constructor for a full description of this invariant. --- Since CastTy cannot be nested, the result of discardCast --- cannot be a CastTy. -discardCast :: Type -> Type -discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty - where - isCastTy CastTy{} = True - isCastTy _ = False -discardCast ty = ty - - -{- --------------------------------------------------------------------- - CoercionTy - ~~~~~~~~~~ -CoercionTy allows us to inject coercions into types. A CoercionTy -should appear only in the right-hand side of an application. --} - -mkCoercionTy :: Coercion -> Type -mkCoercionTy = CoercionTy - -isCoercionTy :: Type -> Bool -isCoercionTy (CoercionTy _) = True -isCoercionTy _ = False - -isCoercionTy_maybe :: Type -> Maybe Coercion -isCoercionTy_maybe (CoercionTy co) = Just co -isCoercionTy_maybe _ = Nothing - -stripCoercionTy :: Type -> Coercion -stripCoercionTy (CoercionTy co) = co -stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) - -{- ---------------------------------------------------------------------- - SynTy - ~~~~~ - -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms wherever possible. Thus - - type Foo a = a -> a - -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) - -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. - - ---------------------------------------------------------------------- - ForAllTy - ~~~~~~~~ --} - --- | Make a dependent forall over an 'Inferred' variable -mkTyCoInvForAllTy :: TyCoVar -> Type -> Type -mkTyCoInvForAllTy tv ty - | isCoVar tv - , not (tv `elemVarSet` tyCoVarsOfType ty) - = mkVisFunTy (varType tv) ty - | otherwise - = ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar -mkInvForAllTy :: TyVar -> Type -> Type -mkInvForAllTy tv ty = ASSERT( isTyVar tv ) - ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Inferred', a common case -mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type -mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs - --- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar -mkInvForAllTys :: [TyVar] -> Type -> Type -mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs - --- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', --- a common case -mkSpecForAllTy :: TyVar -> Type -> Type -mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) - -- covar is always Inferred, so input should be tyvar - ForAllTy (Bndr tv Specified) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Specified', a common case -mkSpecForAllTys :: [TyVar] -> Type -> Type -mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs - --- | Like mkForAllTys, but assumes all variables are dependent and visible -mkVisForAllTys :: [TyVar] -> Type -> Type -mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) - -- covar is always Inferred, so all inputs should be tyvar - mkForAllTys [ Bndr tv Required | tv <- tvs ] - -mkLamType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or an implicit forall type, depending --- on whether it is given a type variable or a term variable. --- This is used, for example, when producing the type of a lambda. --- Always uses Inferred binders. -mkLamTypes :: [Var] -> Type -> Type --- ^ 'mkLamType' for multiple type or value arguments - -mkLamType v body_ty - | isTyVar v - = ForAllTy (Bndr v Inferred) body_ty - - | isCoVar v - , v `elemVarSet` tyCoVarsOfType body_ty - = ForAllTy (Bndr v Required) body_ty - - | isPredTy arg_ty -- See Note [mkLamType: dictionary arguments] - = mkInvisFunTy arg_ty body_ty - - | otherwise - = mkVisFunTy arg_ty body_ty - where - arg_ty = varType v - -mkLamTypes vs ty = foldr mkLamType ty vs - -{- Note [mkLamType: dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have (\ (d :: Ord a). blah), we want to give it type - (Ord a => blah_ty) -with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. - -Why? After all, we are in Core, where (=>) and (->) behave the same. -Yes, but the /specialiser/ does treat dictionary arguments specially. -Suppose we do w/w on 'foo' in module A, thus (#11272, #6056) - foo :: Ord a => Int -> blah - foo a d x = case x of I# x' -> $wfoo @a d x' - - $wfoo :: Ord a => Int# -> blah - -Now in module B we see (foo @Int dOrdInt). The specialiser will -specialise this to $sfoo, where - $sfoo :: Int -> blah - $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' - -Now we /must/ also specialise $wfoo! But it wasn't user-written, -and has a type built with mkLamTypes. - -Conclusion: the easiest thing is to make mkLamType build - (c => ty) -when the argument is a predicate type. See TyCoRep -Note [Types for coercions, predicates, and evidence] --} - --- | Given a list of type-level vars and the free vars of a result kind, --- makes TyCoBinders, preferring anonymous binders --- if the variable is, in fact, not dependent. --- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) --- We want (k:*) Named, (b:k) Anon, (c:k) Anon --- --- All non-coercion binders are /visible/. -mkTyConBindersPreferAnon :: [TyVar] -- ^ binders - -> TyCoVarSet -- ^ free variables of result - -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) - fst (go vars) - where - go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars - go [] = ([], inner_tkvs) - go (v:vs) | v `elemVarSet` fvs - = ( Bndr v (NamedTCB Required) : binders - , fvs `delVarSet` v `unionVarSet` kind_vars ) - | otherwise - = ( Bndr v (AnonTCB VisArg) : binders - , fvs `unionVarSet` kind_vars ) - where - (binders, fvs) = go vs - kind_vars = tyCoVarsOfType $ tyVarKind v - --- | Take a ForAllTy apart, returning the list of tycovars and the result type. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitForAllTys :: Type -> ([TyCoVar], Type) -splitForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Like 'splitForAllTys', but only splits a 'ForAllTy' if --- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility --- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided --- as an argument to this function. -splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) -splitForAllTysSameVis supplied_argf ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Bndr tv argf) ty) tvs - | argf `sameVis` supplied_argf = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Like splitForAllTys, but split only for tyvars. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitTyVarForAllTys :: Type -> ([TyVar], Type) -splitTyVarForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Checks whether this is a proper forall (with a named binder) -isForAllTy :: Type -> Bool -isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' -isForAllTy (ForAllTy {}) = True -isForAllTy _ = False - --- | Like `isForAllTy`, but returns True only if it is a tyvar binder -isForAllTy_ty :: Type -> Bool -isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' -isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True -isForAllTy_ty _ = False - --- | Like `isForAllTy`, but returns True only if it is a covar binder -isForAllTy_co :: Type -> Bool -isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' -isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True -isForAllTy_co _ = False - --- | Is this a function or forall? -isPiTy :: Type -> Bool -isPiTy ty | Just ty' <- coreView ty = isPiTy ty' -isPiTy (ForAllTy {}) = True -isPiTy (FunTy {}) = True -isPiTy _ = False - --- | Is this a function? -isFunTy :: Type -> Bool -isFunTy ty | Just ty' <- coreView ty = isFunTy ty' -isFunTy (FunTy {}) = True -isFunTy _ = False - --- | Take a forall type apart, or panics if that is not possible. -splitForAllTy :: Type -> (TyCoVar, Type) -splitForAllTy ty - | Just answer <- splitForAllTy_maybe ty = answer - | otherwise = pprPanic "splitForAllTy" (ppr ty) - --- | Drops all ForAllTys -dropForAlls :: Type -> Type -dropForAlls ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy _ res) = go res - go res = res - --- | Attempts to take a forall type apart, but only if it's a proper forall, --- with a named binder -splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) - go _ = Nothing - --- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. -splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_ty_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) - go _ = Nothing - --- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. -splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_co_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) - go _ = Nothing - --- | Attempts to take a forall type apart; works with proper foralls and --- functions -splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) -splitPiTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy bndr ty) = Just (Named bndr, ty) - go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) - = Just (Anon af arg, res) - go _ = Nothing - --- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyCoBinder, Type) -splitPiTy ty - | Just answer <- splitPiTy_maybe ty = answer - | otherwise = pprPanic "splitPiTy" (ppr ty) - --- | Split off all TyCoBinders to a type, splitting both proper foralls --- and functions -splitPiTys :: Type -> ([TyCoBinder], Type) -splitPiTys ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (Named b : bs) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs - = split res res (Anon af arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) - --- | Like 'splitPiTys' but split off only /named/ binders --- and returns TyCoVarBinders rather than TyCoBinders -splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) -splitForAllVarBndrs ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) -{-# INLINE splitForAllVarBndrs #-} - -invisibleTyBndrCount :: Type -> Int --- Returns the number of leading invisible forall'd binders in the type --- Includes invisible predicate arguments; e.g. for --- e.g. forall {k}. (k ~ *) => k -> k --- returns 2 not 1 -invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) - --- Like splitPiTys, but returns only *invisible* binders, including constraints --- Stops at the first visible binder -splitPiTysInvisible :: Type -> ([TyCoBinder], Type) -splitPiTysInvisible ty = split ty ty [] - where - split orig_ty ty bs - | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs - | Bndr _ vis <- b - , isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs - = split res res (Anon InvisArg arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) - -splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) --- Same as splitPiTysInvisible, but stop when --- - you have found 'n' TyCoBinders, --- - or you run out of invisible binders -splitPiTysInvisibleN n ty = split n ty ty [] - where - split n orig_ty ty bs - | n == 0 = (reverse bs, orig_ty) - | Just ty' <- coreView ty = split n orig_ty ty' bs - | ForAllTy b res <- ty - , Bndr _ vis <- b - , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) - | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty - = split (n-1) res res (Anon InvisArg arg : bs) - | otherwise = (reverse bs, orig_ty) - --- | Given a 'TyCon' and a list of argument types, filter out any invisible --- (i.e., 'Inferred' or 'Specified') arguments. -filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] -filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys - --- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' --- arguments. -filterOutInferredTypes :: TyCon -> [Type] -> [Type] -filterOutInferredTypes tc tys = - filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys - --- | Given a 'TyCon' and a list of argument types, partition the arguments --- into: --- --- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and --- --- 2. 'Required' (i.e., visible) arguments -partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) -partitionInvisibleTypes tc tys = - partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys - --- | Given a list of things paired with their visibilities, partition the --- things into (invisible things, visible things). -partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) -partitionInvisibles = partitionWith pick_invis - where - pick_invis :: (a, ArgFlag) -> Either a a - pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing - | otherwise = Right thing - --- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Wrinkle: consider the following scenario: --- --- > T :: forall k. k -> k --- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] --- --- After substituting, we get --- --- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n --- --- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, --- and @Q@ is visible. -tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] -tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) - --- | Given a 'Type' and a list of argument types to which the 'Type' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Most of the time, the arguments will be 'Required', but not always. Consider --- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is --- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely --- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, --- since @f Type Bool@ would be represented in Core using 'AppTy's. --- (See also #15792). -appTyArgFlags :: Type -> [Type] -> [ArgFlag] -appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) - --- | Given a function kind and a list of argument types (where each argument's --- kind aligns with the corresponding position in the argument kind), determine --- each argument's visibility ('Inferred', 'Specified', or 'Required'). -fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] -fun_kind_arg_flags = go emptyTCvSubst - where - go subst ki arg_tys - | Just ki' <- coreView ki = go subst ki' arg_tys - go _ _ [] = [] - go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) - = argf : go subst' res_ki arg_tys - where - subst' = extendTvSubst subst tv arg_ty - go subst (TyVarTy tv) arg_tys - | Just ki <- lookupTyVar subst tv = go subst ki arg_tys - -- This FunTy case is important to handle kinds with nested foralls, such - -- as this kind (inspired by #16518): - -- - -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type - -- - -- Here, we want to get the following ArgFlags: - -- - -- [Inferred, Specified, Required, Required, Specified, Required] - -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type - go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) - = argf : go subst res_ki arg_tys - where - argf = case af of - VisArg -> Required - InvisArg -> Inferred - go _ _ arg_tys = map (const Required) arg_tys - -- something is ill-kinded. But this can happen - -- when printing errors. Assume everything is Required. - --- @isTauTy@ tests if a type has no foralls -isTauTy :: Type -> Bool -isTauTy ty | Just ty' <- coreView ty = isTauTy ty' -isTauTy (TyVarTy _) = True -isTauTy (LitTy {}) = True -isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy _ a b) = isTauTy a && isTauTy b -isTauTy (ForAllTy {}) = False -isTauTy (CastTy ty _) = isTauTy ty -isTauTy (CoercionTy _) = False -- Not sure about this - -{- -%************************************************************************ -%* * - TyCoBinders -%* * -%************************************************************************ --} - --- | Make an anonymous binder -mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder -mkAnonBinder = Anon - --- | Does this binder bind a variable that is /not/ erased? Returns --- 'True' for anonymous binders. -isAnonTyCoBinder :: TyCoBinder -> Bool -isAnonTyCoBinder (Named {}) = False -isAnonTyCoBinder (Anon {}) = True - -tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar -tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv -tyCoBinderVar_maybe _ = Nothing - -tyCoBinderType :: TyCoBinder -> Type -tyCoBinderType (Named tvb) = binderType tvb -tyCoBinderType (Anon _ ty) = ty - -tyBinderType :: TyBinder -> Type -tyBinderType (Named (Bndr tv _)) - = ASSERT( isTyVar tv ) - tyVarKind tv -tyBinderType (Anon _ ty) = ty - --- | Extract a relevant type, if there is one. -binderRelevantType_maybe :: TyCoBinder -> Maybe Type -binderRelevantType_maybe (Named {}) = Nothing -binderRelevantType_maybe (Anon _ ty) = Just ty - -{- -************************************************************************ -* * -\subsection{Type families} -* * -************************************************************************ --} - -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) - zipTvSubst tvs tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys - --- | Get the type on the LHS of a coercion induced by a type/data --- family instance. -coAxNthLHS :: CoAxiom br -> Int -> Type -coAxNthLHS ax ind = - mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) - -isFamFreeTy :: Type -> Bool -isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' -isFamFreeTy (TyVarTy _) = True -isFamFreeTy (LitTy {}) = True -isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc -isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty -isFamFreeTy (CastTy ty _) = isFamFreeTy ty -isFamFreeTy (CoercionTy _) = False -- Not sure about this - --- | Does this type classify a core (unlifted) Coercion? --- At either role nominal or representational --- (t1 ~# t2) or (t1 ~R# t2) --- See Note [Types for coercions, predicates, and evidence] in TyCoRep -isCoVarType :: Type -> Bool - -- ToDo: should we check saturation? -isCoVarType ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey - | otherwise - = False - -buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> KnotTied Type -> TyCon --- This function is here beucase here is where we have --- isFamFree and isTauTy -buildSynTyCon name binders res_kind roles rhs - = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free - where - is_tau = isTauTy rhs - is_fam_free = isFamFreeTy rhs - -{- -************************************************************************ -* * -\subsection{Liftedness} -* * -************************************************************************ --} - --- | Returns Just True if this type is surely lifted, Just False --- if it is surely unlifted, Nothing if we can't be sure (i.e., it is --- levity polymorphic), and panics if the kind does not have the shape --- TYPE r. -isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool -isLiftedType_maybe ty = go (getRuntimeRep ty) - where - go rr | Just rr' <- coreView rr = go rr' - | isLiftedRuntimeRep rr = Just True - | TyConApp {} <- rr = Just False -- Everything else is unlifted - | otherwise = Nothing -- levity polymorphic - --- | See "Type#type_classification" for what an unlifted type is. --- Panics on levity polymorphic types; See 'mightBeUnliftedType' for --- a more approximate predicate that behaves better in the presence of --- levity polymorphism. -isUnliftedType :: HasDebugCallStack => Type -> Bool - -- isUnliftedType returns True for forall'd unlifted types: - -- x :: forall a. Int# - -- I found bindings like these were getting floated to the top level. - -- They are pretty bogus types, mind you. It would be better never to - -- construct them -isUnliftedType ty - = not (isLiftedType_maybe ty `orElse` - pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) - --- | Returns: --- --- * 'False' if the type is /guaranteed/ lifted or --- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case) -mightBeUnliftedType :: Type -> Bool -mightBeUnliftedType ty - = case isLiftedType_maybe ty of - Just is_lifted -> not is_lifted - Nothing -> True - --- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) -isRuntimeRepKindedTy :: Type -> Bool -isRuntimeRepKindedTy = isRuntimeRepTy . typeKind - --- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. --- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: --- --- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep --- , String, Int# ] == [String, Int#] --- -dropRuntimeRepArgs :: [Type] -> [Type] -dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not --- possible. -getRuntimeRep_maybe :: HasDebugCallStack - => Type -> Maybe Type -getRuntimeRep_maybe = kindRep_maybe . typeKind - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. -getRuntimeRep :: HasDebugCallStack => Type -> Type -getRuntimeRep ty - = case getRuntimeRep_maybe ty of - Just r -> r - Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - -isUnboxedTupleType :: Type -> Bool -isUnboxedTupleType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey - -- NB: Do not use typePrimRep, as that can't tell the difference between - -- unboxed tuples and unboxed sums - - -isUnboxedSumType :: Type -> Bool -isUnboxedSumType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey - --- | See "Type#type_classification" for what an algebraic type is. --- Should only be applied to /types/, as opposed to e.g. partially --- saturated type constructors -isAlgType :: Type -> Bool -isAlgType ty - = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc - _other -> False - --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - --- | Computes whether an argument (or let right hand side) should --- be computed strictly or lazily, based only on its type. --- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. -isStrictType :: HasDebugCallStack => Type -> Bool -isStrictType = isUnliftedType - -isPrimitiveType :: Type -> Bool --- ^ Returns true of types that are opaque to Haskell. -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isPrimTyCon tc - _ -> False - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Determine whether a type could be the type of a join point of given total --- arity, according to the polymorphism rule. A join point cannot be polymorphic --- in its return type, since given --- join j @a @b x y z = e1 in e2, --- the types of e1 and e2 must be the same, and a and b are not in scope for e2. --- (See Note [The polymorphism rule of join points] in GHC.Core.) Returns False --- also if the type simply doesn't have enough arguments. --- --- Note that we need to know how many arguments (type *and* value) the putative --- join point takes; for instance, if --- j :: forall a. a -> Int --- then j could be a binary join point returning an Int, but it could *not* be a --- unary join point returning a -> Int. --- --- TODO: See Note [Excess polymorphism and join points] -isValidJoinPointType :: JoinArity -> Type -> Bool -isValidJoinPointType arity ty - = valid_under emptyVarSet arity ty - where - valid_under tvs arity ty - | arity == 0 - = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) - | Just (t, ty') <- splitForAllTy_maybe ty - = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, res_ty) <- splitFunTy_maybe ty - = valid_under tvs (arity-1) res_ty - | otherwise - = False - -{- Note [Excess polymorphism and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In principle, if a function would be a join point except that it fails -the polymorphism rule (see Note [The polymorphism rule of join points] in -GHC.Core), it can still be made a join point with some effort. This is because -all tail calls must return the same type (they return to the same context!), and -thus if the return type depends on an argument, that argument must always be the -same. - -For instance, consider: - - let f :: forall a. a -> Char -> [a] - f @a x c = ... f @a y 'a' ... - in ... f @Int 1 'b' ... f @Int 2 'c' ... - -(where the calls are tail calls). `f` fails the polymorphism rule because its -return type is [a], where [a] is bound. But since the type argument is always -'Int', we can rewrite it as: - - let f' :: Int -> Char -> [Int] - f' x c = ... f' y 'a' ... - in ... f' 1 'b' ... f 2 'c' ... - -and now we can make f' a join point: - - join f' :: Int -> Char -> [Int] - f' x c = ... jump f' y 'a' ... - in ... jump f' 1 'b' ... jump f' 2 'c' ... - -It's not clear that this comes up often, however. TODO: Measure how often and -add this analysis if necessary. See #14620. - - -************************************************************************ -* * -\subsection{Sequencing on types} -* * -************************************************************************ --} - -seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty -seqType (CastTy ty co) = seqType ty `seq` seqCo co -seqType (CoercionTy co) = seqCo co - -seqTypes :: [Type] -> () -seqTypes [] = () -seqTypes (ty:tys) = seqType ty `seq` seqTypes tys - -{- -************************************************************************ -* * - Comparison for types - (We don't use instances so that we know where it happens) -* * -************************************************************************ - -Note [Equality on AppTys] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In our cast-ignoring equality, we want to say that the following two -are equal: - - (Maybe |> co) (Int |> co') ~? Maybe Int - -But the left is an AppTy while the right is a TyConApp. The solution is -to use repSplitAppTy_maybe to break up the TyConApp into its pieces and -then continue. Easy to do, but also easy to forget to do. - --} - -eqType :: Type -> Type -> Bool --- ^ Type equality on source types. Does not look through @newtypes@ or --- 'PredType's, but it does look through type synonyms. --- This first checks that the kinds of the types are equal and then --- checks whether the types are equal, ignoring casts and coercions. --- (The kind check is a recursive call, but since all kinds have type --- @Type@, there is no need to check the types of kinds.) --- See also Note [Non-trivial definitional equality] in TyCoRep. -eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 - -- It's OK to use nonDetCmpType here and eqType is deterministic, - -- nonDetCmpType does equality deterministically - --- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. -eqTypeX :: RnEnv2 -> Type -> Type -> Bool -eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 - -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, - -- nonDetCmpTypeX does equality deterministically - --- | Type equality on lists of types, looking through type synonyms --- but not newtypes. -eqTypes :: [Type] -> [Type] -> Bool -eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 - -- It's OK to use nonDetCmpType here and eqTypes is deterministic, - -- nonDetCmpTypes does equality deterministically - -eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 --- Check that the var lists are the same length --- and have matching kinds; if so, extend the RnEnv2 --- Returns Nothing if they don't match -eqVarBndrs env [] [] - = Just env -eqVarBndrs env (tv1:tvs1) (tv2:tvs2) - | eqTypeX env (varType tv1) (varType tv2) - = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqVarBndrs _ _ _= Nothing - --- Now here comes the real worker - -{- -Note [nonDetCmpType nondeterminism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX -uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for -ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, -comparing type variables is nondeterministic, note the call to nonDetCmpVar in -nonDetCmpTypeX. -See Note [Unique Determinism] for more details. --} - -nonDetCmpType :: Type -> Type -> Ordering -nonDetCmpType t1 t2 - -- we know k1 and k2 have the same kind, because they both have kind *. - = nonDetCmpTypeX rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) - -nonDetCmpTypes :: [Type] -> [Type] -> Ordering -nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) - --- | An ordering relation between two 'Type's (known below as @t1 :: k1@ --- and @t2 :: k2@) -data TypeOrdering = TLT -- ^ @t1 < t2@ - | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, - -- therefore we can conclude @k1 ~ k2@ - | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so - -- they may differ in kind. - | TGT -- ^ @t1 > t2@ - deriving (Eq, Ord, Enum, Bounded) - -nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse - -- See Note [Non-trivial definitional equality] in TyCoRep -nonDetCmpTypeX env orig_t1 orig_t2 = - case go env orig_t1 orig_t2 of - -- If there are casts then we also need to do a comparison of the kinds of - -- the types being compared - TEQX -> toOrdering $ go env k1 k2 - ty_ordering -> toOrdering ty_ordering - where - k1 = typeKind orig_t1 - k2 = typeKind orig_t2 - - toOrdering :: TypeOrdering -> Ordering - toOrdering TLT = LT - toOrdering TEQ = EQ - toOrdering TEQX = EQ - toOrdering TGT = GT - - liftOrdering :: Ordering -> TypeOrdering - liftOrdering LT = TLT - liftOrdering EQ = TEQ - liftOrdering GT = TGT - - thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering - thenCmpTy TEQ rel = rel - thenCmpTy TEQX rel = hasCast rel - thenCmpTy rel _ = rel - - hasCast :: TypeOrdering -> TypeOrdering - hasCast TEQ = TEQX - hasCast rel = rel - - -- Returns both the resulting ordering relation between the two types - -- and whether either contains a cast. - go :: RnEnv2 -> Type -> Type -> TypeOrdering - go env t1 t2 - | Just t1' <- coreView t1 = go env t1' t2 - | Just t2' <- coreView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) - = go env (varType tv1) (varType tv2) - `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 - -- See Note [Equality on AppTys] - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- repSplitAppTy_maybe ty2 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- repSplitAppTy_maybe ty1 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (FunTy _ s1 t1) (FunTy _ s2 t2) - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 - go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) - go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 - go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 - - go _ (CoercionTy {}) (CoercionTy {}) = TEQ - - -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy - go _ ty1 ty2 - = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) - where get_rank :: Type -> Int - get_rank (CastTy {}) - = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) - get_rank (TyVarTy {}) = 0 - get_rank (CoercionTy {}) = 1 - get_rank (AppTy {}) = 3 - get_rank (LitTy {}) = 4 - get_rank (TyConApp {}) = 5 - get_rank (FunTy {}) = 6 - get_rank (ForAllTy {}) = 7 - - gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering - gos _ [] [] = TEQ - gos _ [] _ = TLT - gos _ _ [] = TGT - gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 - -------------- -nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -nonDetCmpTypesX _ [] [] = EQ -nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 - `thenCmp` - nonDetCmpTypesX env tys1 tys2 -nonDetCmpTypesX _ [] _ = LT -nonDetCmpTypesX _ _ [] = GT - -------------- --- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as --- recognized by Kind.isConstraintKindCon) which is considered a synonym for --- 'Type' in Core. --- See Note [Kind Constraint and kind Type] in Kind. --- See Note [nonDetCmpType nondeterminism] -nonDetCmpTc :: TyCon -> TyCon -> Ordering -nonDetCmpTc tc1 tc2 - = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) - u1 `nonDetCmpUnique` u2 - where - u1 = tyConUnique tc1 - u2 = tyConUnique tc2 - -{- -************************************************************************ -* * - The kind of a type -* * -************************************************************************ - -Note [typeKind vs tcTypeKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have two functions to get the kind of a type - - * typeKind ignores the distinction between Constraint and * - * tcTypeKind respects the distinction between Constraint and * - -tcTypeKind is used by the type inference engine, for which Constraint -and * are different; after that we use typeKind. - -See also Note [coreView vs tcView] - -Note [Kinding rules for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. -We then have - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - ty : TYPE rep - `a` is not free in rep -(FORALL) ----------------------- - forall a. ty : TYPE rep - -In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - t1 : Constraint - t2 : TYPE rep - (PRED1) ---------------- - t1 => t2 : Type - - t1 : Constraint - t2 : Constraint - (PRED2) --------------------- - t1 => t2 : Constraint - - ty : TYPE rep - `a` is not free in rep -(FORALL1) ----------------------- - forall a. ty : TYPE rep - - ty : Constraint -(FORALL2) ------------------------- - forall a. ty : Constraint - -Note that: -* The only way we distinguish '->' from '=>' is by the fact - that the argument is a PredTy. Both are FunTys - -Note [Phantom type variables in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - type K (r :: RuntimeRep) = Type -- Note 'r' is unused - data T r :: K r -- T :: forall r -> K r - foo :: forall r. T r - -The body of the forall in foo's type has kind (K r), and -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 - forall r. T r - -To accommodate such a type, in typeKind (forall a.ty) we use -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. --} - ------------------------------ -typeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -typeKind (LitTy l) = typeLiteralKind l -typeKind (FunTy {}) = liftedTypeKind -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (CastTy _ty co) = coercionRKind co -typeKind (CoercionTy co) = coercionType co - -typeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arguments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - go fun args = piResultTys (typeKind fun) args - -typeKind ty@(ForAllTy {}) - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "typeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - where - (tvs, body) = splitTyVarForAllTys ty - body_kind = typeKind body - ---------------------------------------------- --- Utilities to be used in Unify, which uses "tc" functions ---------------------------------------------- - -tcTypeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -tcTypeKind (LitTy l) = typeLiteralKind l -tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar -tcTypeKind (CastTy _ty co) = coercionRKind co -tcTypeKind (CoercionTy co) = coercionType co - -tcTypeKind (FunTy { ft_af = af, ft_res = res }) - | InvisArg <- af - , tcIsConstraintKind (tcTypeKind res) - = constraintKind -- Eq a => Ord a :: Constraint - | otherwise -- Eq a => a -> a :: TYPE LiftedRep - = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) - -tcTypeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arguments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - go fun args = piResultTys (tcTypeKind fun) args - -tcTypeKind ty@(ForAllTy {}) - | tcIsConstraintKind body_kind - = constraintKind - - | otherwise - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "tcTypeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - where - (tvs, body) = splitTyVarForAllTys ty - body_kind = tcTypeKind body - - -isPredTy :: HasDebugCallStack => Type -> Bool --- See Note [Types for coercions, predicates, and evidence] in TyCoRep -isPredTy ty = tcIsConstraintKind (tcTypeKind ty) - --- tcIsConstraintKind stuff only makes sense in the typechecker --- After that Constraint = Type --- See Note [coreView vs tcView] --- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) -tcIsConstraintKind :: Kind -> Bool -tcIsConstraintKind ty - | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , isConstraintKindCon tc - = ASSERT2( null args, ppr ty ) True - - | otherwise - = False - --- | Is this kind equivalent to @*@? --- --- This considers 'Constraint' to be distinct from @*@. For a version that --- treats them as the same type, see 'isLiftedTypeKind'. -tcIsLiftedTypeKind :: Kind -> Bool -tcIsLiftedTypeKind ty - | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , tc `hasKey` tYPETyConKey - = isLiftedRuntimeRep arg - | otherwise - = False - --- | Is this kind equivalent to @TYPE r@ (for some unknown r)? --- --- This considers 'Constraint' to be distinct from @*@. -tcIsRuntimeTypeKind :: Kind -> Bool -tcIsRuntimeTypeKind ty - | Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , tc `hasKey` tYPETyConKey - = True - | otherwise - = False - -tcReturnsConstraintKind :: Kind -> Bool --- True <=> the Kind ultimately returns a Constraint --- E.g. * -> Constraint --- forall k. k -> Constraint -tcReturnsConstraintKind kind - | Just kind' <- tcView kind = tcReturnsConstraintKind kind' -tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc -tcReturnsConstraintKind _ = False - --------------------------- -typeLiteralKind :: TyLit -> Kind -typeLiteralKind (NumTyLit {}) = typeNatKind -typeLiteralKind (StrTyLit {}) = typeSymbolKind - --- | Returns True if a type is levity polymorphic. Should be the same --- as (isKindLevPoly . typeKind) but much faster. --- Precondition: The type has kind (TYPE blah) -isTypeLevPoly :: Type -> Bool -isTypeLevPoly = go - where - go ty@(TyVarTy {}) = check_kind ty - go ty@(AppTy {}) = check_kind ty - go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False - | otherwise = check_kind ty - go (ForAllTy _ ty) = go ty - go (FunTy {}) = False - go (LitTy {}) = False - go ty@(CastTy {}) = check_kind ty - go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) - - check_kind = isKindLevPoly . typeKind - --- | Looking past all pi-types, is the end result potentially levity polymorphic? --- Example: True for (forall r (a :: TYPE r). String -> a) --- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) -resultIsLevPoly :: Type -> Bool -resultIsLevPoly = isTypeLevPoly . snd . splitPiTys - - -{- ********************************************************************** -* * - Occurs check expansion -%* * -%********************************************************************* -} - -{- Note [Occurs check expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid -of occurrences of tv outside type function arguments, if that is -possible; otherwise, it returns Nothing. - -For example, suppose we have - type F a b = [a] -Then - occCheckExpand b (F Int b) = Just [Int] -but - occCheckExpand a (F a Int) = Nothing - -We don't promise to do the absolute minimum amount of expanding -necessary, but we try not to do expansions we don't need to. We -prefer doing inner expansions first. For example, - type F a b = (a, Int, a, [a]) - type G b = Char -We have - occCheckExpand b (F (G b)) = Just (F Char) -even though we could also expand F to get rid of b. --} - -occCheckExpand :: [Var] -> Type -> Maybe Type --- See Note [Occurs check expansion] --- We may have needed to do some type synonym unfolding in order to --- get rid of the variable (or forall), so we also return the unfolded --- version of the type, which is guaranteed to be syntactically free --- of the given type variable. If the type is already syntactically --- free of the variable, then the same type is returned. -occCheckExpand vs_to_avoid ty - | null vs_to_avoid -- Efficient shortcut - = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase - - | otherwise - = go (mkVarSet vs_to_avoid, emptyVarEnv) ty - where - go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type - -- The VarSet is the set of variables we are trying to avoid - -- The VarEnv carries mappings necessary - -- because of kind expansion - go cxt@(as, env) (TyVarTy tv') - | tv' `elemVarSet` as = Nothing - | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') - | otherwise = do { tv'' <- go_var cxt tv' - ; return (mkTyVarTy tv'') } - - go _ ty@(LitTy {}) = return ty - go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkAppTy ty1' ty2') } - go cxt ty@(FunTy _ ty1 ty2) - = do { ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (ty { ft_arg = ty1', ft_res = ty2' }) } - go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) - = do { ki' <- go cxt (varType tv) - ; let tv' = setVarType tv ki' - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go (as', env') body_ty - ; return (ForAllTy (Bndr tv' vis) body') } - - -- For a type constructor application, first try expanding away the - -- offending variable from the arguments. If that doesn't work, next - -- see if the type constructor is a type synonym, and if so, expand - -- it and try again. - go cxt ty@(TyConApp tc tys) - = case mapM (go cxt) tys of - Just tys' -> return (mkTyConApp tc tys') - Nothing | Just ty' <- tcView ty -> go cxt ty' - | otherwise -> Nothing - -- Failing that, try to expand a synonym - - go cxt (CastTy ty co) = do { ty' <- go cxt ty - ; co' <- go_co cxt co - ; return (mkCastTy ty' co') } - go cxt (CoercionTy co) = do { co' <- go_co cxt co - ; return (mkCoercionTy co') } - - ------------------ - go_var cxt v = do { k' <- go cxt (varType v) - ; return (setVarType v k') } - -- Works for TyVar and CoVar - -- See Note [Occurrence checking: look inside kinds] - - ------------------ - go_mco _ MRefl = return MRefl - go_mco ctx (MCo co) = MCo <$> go_co ctx co - - ------------------ - go_co cxt (Refl ty) = do { ty' <- go cxt ty - ; return (mkNomReflCo ty') } - go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco - ; ty' <- go cxt ty - ; return (mkGReflCo r ty' mco') } - -- Note: Coercions do not contain type synonyms - go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args - ; return (mkTyConAppCo r tc args') } - go_co cxt (AppCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkAppCo co' arg') } - go_co cxt@(as, env) (ForAllCo tv kind_co body_co) - = do { kind_co' <- go_co cxt kind_co - ; let tv' = setVarType tv $ - coercionLKind kind_co' - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go_co (as', env') body_co - ; return (ForAllCo tv' kind_co' body') } - go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (mkFunCo r co1' co2') } - go_co cxt@(as,env) (CoVarCo c) - | c `elemVarSet` as = Nothing - | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') - | otherwise = do { c' <- go_var cxt c - ; return (mkCoVarCo c') } - go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) - ; return (HoleCo (h { ch_co_var = c' })) } - go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args - ; return (mkAxiomInstCo ax ind args') } - go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p - ; ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkUnivCo p' r ty1' ty2') } - go_co cxt (SymCo co) = do { co' <- go_co cxt co - ; return (mkSymCo co') } - go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (mkTransCo co1' co2') } - go_co cxt (NthCo r n co) = do { co' <- go_co cxt co - ; return (mkNthCo r n co') } - go_co cxt (LRCo lr co) = do { co' <- go_co cxt co - ; return (mkLRCo lr co') } - go_co cxt (InstCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkInstCo co' arg') } - go_co cxt (KindCo co) = do { co' <- go_co cxt co - ; return (mkKindCo co') } - go_co cxt (SubCo co) = do { co' <- go_co cxt co - ; return (mkSubCo co') } - go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs - ; return (mkAxiomRuleCo ax cs') } - - ------------------ - go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co - go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co - go_prov _ p@(PluginProv _) = return p - - -{- -%************************************************************************ -%* * - Miscellaneous functions -%* * -%************************************************************************ - --} --- | All type constructors occurring in the type; looking through type --- synonyms, but not newtypes. --- When it finds a Class, it returns the class TyCon. -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - = go ty - where - go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyUniqSet - go (LitTy {}) = emptyUniqSet - go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys - go (AppTy a b) = go a `unionUniqSets` go b - go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon - go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) - go (CastTy ty co) = go ty `unionUniqSets` go_co co - go (CoercionTy co) = go_co co - - go_co (Refl ty) = go ty - go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco - go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args - go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co - go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args - go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 - go_co (CoVarCo {}) = emptyUniqSet - go_co (HoleCo {}) = emptyUniqSet - go_co (SymCo co) = go_co co - go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_cos cs - - go_mco MRefl = emptyUniqSet - go_mco (MCo co) = go_co co - - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyUniqSet - -- this last case can happen from the tyConsOfType used from - -- checkTauTvUpdate - - go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys - go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos - - go_tc tc = unitUniqSet tc - go_ax ax = go_tc $ coAxiomTyCon ax - --- | Find the result 'Kind' of a type synonym, --- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, --- but they'd always return '*', so we never need to ask -synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) - --- | Retrieve the free variables in this type, splitting them based --- on whether they are used visibly or invisibly. Invisible ones come --- first. -splitVisVarsOfType :: Type -> Pair TyCoVarSet -splitVisVarsOfType orig_ty = Pair invis_vars vis_vars - where - Pair invis_vars1 vis_vars = go orig_ty - invis_vars = invis_vars1 `minusVarSet` vis_vars - - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) - go (AppTy t1 t2) = go t1 `mappend` go t2 - go (TyConApp tc tys) = go_tc tc tys - go (FunTy _ t1 t2) = go t1 `mappend` go t2 - go (ForAllTy (Bndr tv _) ty) - = ((`delVarSet` tv) <$> go ty) `mappend` - (invisible (tyCoVarsOfType $ varType tv)) - go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) - go (CoercionTy co) = invisible $ tyCoVarsOfCo co - - invisible vs = Pair vs emptyVarSet - - go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in - invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis - -splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet -splitVisVarsOfTypes = foldMap splitVisVarsOfType - -modifyJoinResTy :: Int -- Number of binders to skip - -> (Type -> Type) -- Function to apply to result type - -> Type -- Type of join point - -> Type -- New type --- INVARIANT: If any of the first n binders are foralls, those tyvars cannot --- appear in the original result type. See isValidJoinPointType. -modifyJoinResTy orig_ar f orig_ty - = go orig_ar orig_ty - where - go 0 ty = f ty - go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty - = mkPiTy arg_bndr (go (n-1) res_ty) - | otherwise - = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) - -setJoinResTy :: Int -- Number of binders to skip - -> Type -- New result type - -> Type -- Type of join point - -> Type -- New type --- INVARIANT: Same as for modifyJoinResTy -setJoinResTy ar new_res_ty ty - = modifyJoinResTy ar (const new_res_ty) ty - -{- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ - -Note [Kind Constraint and kind Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that - * They are displayed with double arrow: - f :: Ord a => a -> a - * They are implicitly instantiated at call sites; so the type inference - engine inserts an extra argument of type (Ord a) at every call site - to f. - -However, once type inference is over, there is *no* distinction between -Constraint and Type. Indeed we can have coercions between the two. Consider - class C a where - op :: a -> a -For this single-method class we may generate a newtype, which in turn -generates an axiom witnessing - C a ~ (a -> a) -so on the left we have Constraint, and on the right we have Type. -See #7451. - -Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except -during type inference. --} - -isConstraintKindCon :: TyCon -> Bool -isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey - --- | Tests whether the given kind (which should look like @TYPE x@) --- is something other than a constructor tree (that is, constructors at every node). --- E.g. True of TYPE k, TYPE (F Int) --- False of TYPE 'LiftedRep -isKindLevPoly :: Kind -> Bool -isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) - -- the isLiftedTypeKind check is necessary b/c of Constraint - go k - where - go ty | Just ty' <- coreView ty = go ty' - go TyVarTy{} = True - go AppTy{} = True -- it can't be a TyConApp - go (TyConApp tc tys) = isFamilyTyCon tc || any go tys - go ForAllTy{} = True - go (FunTy _ t1 t2) = go t1 || go t2 - go LitTy{} = False - go CastTy{} = True - go CoercionTy{} = True - - _is_type = classifiesTypeWithValues k - ------------------------------------------ --- Subkinding --- The tc variants are used during type-checking, where ConstraintKind --- is distinct from all other kinds --- After type-checking (in core), Constraint and liftedTypeKind are --- indistinguishable - --- | Does this classify a type allowed to have values? Responds True to things --- like *, #, TYPE Lifted, TYPE v, Constraint. -classifiesTypeWithValues :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind -classifiesTypeWithValues k = isJust (kindRep_maybe k) - -{- -%************************************************************************ -%* * - Pretty-printing -%* * -%************************************************************************ - -Most pretty-printing is either in TyCoRep or GHC.Iface.Type. - --} - --- | Does a 'TyCon' (that is applied to some number of arguments) need to be --- ascribed with an explicit kind signature to resolve ambiguity if rendered as --- a source-syntax type? --- (See @Note [When does a tycon application need an explicit kind signature?]@ --- for a full explanation of what this function checks for.) -tyConAppNeedsKindSig - :: Bool -- ^ Should specified binders count towards injective positions in - -- the kind of the TyCon? (If you're using visible kind - -- applications, then you want True here. - -> TyCon - -> Int -- ^ The number of args the 'TyCon' is applied to. - -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the - -- number of arguments) -tyConAppNeedsKindSig spec_inj_pos tc n_args - | LT <- listLengthCmp tc_binders n_args - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAt n_args tc_binders - result_kind = mkTyConKind remaining_binders tc_res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injective_vars_of_binder dropped_binders - - in not (subVarSet result_vars dropped_vars) - where - tc_binders = tyConBinders tc - tc_res_kind = tyConResKind tc - - -- Returns the variables that would be fixed by knowing a TyConBinder. See - -- Note [When does a tycon application need an explicit kind signature?] - -- for a more detailed explanation of what this function does. - injective_vars_of_binder :: TyConBinder -> FV - injective_vars_of_binder (Bndr tv vis) = - case vis of - AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice - (varType tv) - NamedTCB argf | source_of_injectivity argf - -> unitFV tv `unionFV` - injectiveVarsOfType False (varType tv) - _ -> emptyFV - - source_of_injectivity Required = True - source_of_injectivity Specified = spec_inj_pos - source_of_injectivity Inferred = False - -{- -Note [When does a tycon application need an explicit kind signature?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a couple of places in GHC where we convert Core Types into forms that -more closely resemble user-written syntax. These include: - -1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) -2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) - -This conversion presents a challenge: how do we ensure that the resulting type -has enough kind information so as not to be ambiguous? To better motivate this -question, consider the following Core type: - - -- Foo :: Type -> Type - type Foo = Proxy Type - -There is nothing ambiguous about the RHS of Foo in Core. But if we were to, -say, reify it into a TH Type, then it's tempting to just drop the invisible -Type argument and simply return `Proxy`. But now we've lost crucial kind -information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` -or `Proxy Int` or something else! We've inadvertently introduced ambiguity. - -Unlike in other situations in GHC, we can't just turn on --fprint-explicit-kinds, as we need to produce something which has the same -structure as a source-syntax type. Moreover, we can't rely on visible kind -application, since the first kind argument to Proxy is inferred, not specified. -Our solution is to annotate certain tycons with their kinds whenever they -appear in applied form in order to resolve the ambiguity. For instance, we -would reify the RHS of Foo like so: - - type Foo = (Proxy :: Type -> Type) - -We need to devise an algorithm that determines precisely which tycons need -these explicit kind signatures. We certainly don't want to annotate _every_ -tycon with a kind signature, or else we might end up with horribly bloated -types like the following: - - (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) - -We only want to annotate tycons that absolutely require kind signatures in -order to resolve some sort of ambiguity, and nothing more. - -Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type -require a kind signature? It might require it when we need to fill in any of -T's omitted arguments. By "omitted argument", we mean one that is dropped when -reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and -specified arguments (e.g., TH reification in TcSplice), and sometimes the -omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, -which reifies specified arguments through visible kind application). -Regardless, the key idea is that _some_ arguments are going to be omitted after -reification, and the only mechanism we have at our disposal for filling them in -is through explicit kind signatures. - -What do we mean by "fill in"? Let's consider this small example: - - T :: forall {k}. Type -> (k -> Type) -> k - -Moreover, we have this application of T: - - T @{j} Int aty - -When we reify this type, we omit the inferred argument @{j}. Is it fixed by the -other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then -we'll generate an equality constraint (kappa -> Type) and, assuming we can -solve it, that will fix `kappa`. (Here, `kappa` is the unification variable -that we instantiate `k` with.) - -Therefore, for any application of a tycon T to some arguments, the Question We -Must Answer is: - -* Given the first n arguments of T, do the kinds of the non-omitted arguments - fill in the omitted arguments? - -(This is still a bit hand-wavey, but we'll refine this question incrementally -as we explain more of the machinery underlying this process.) - -Answering this question is precisely the role that the `injectiveVarsOfType` -and `injective_vars_of_binder` functions exist to serve. If an omitted argument -`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing -`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a -bit.) - -More formally, if -`a` is in `injectiveVarsOfType ty` -and S1(ty) ~ S2(ty), -then S1(a) ~ S2(a), -where S1 and S2 are arbitrary substitutions. - -For example, is `F` is a non-injective type family, then - - injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} - -Now that we know what this function does, here is a second attempt at the -Question We Must Answer: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. Do the injective - variables of these binders fill in the remainder of T's kind? - -Alright, we're getting closer. Next, we need to clarify what the injective -variables of a tycon binder are. This the role that the -`injective_vars_of_binder` function serves. Here is what this function does for -each form of tycon binder: - -* Anonymous binders are injective positions. For example, in the promoted data - constructor '(:): - - '(:) :: forall a. a -> [a] -> [a] - - The second and third tyvar binders (of kinds `a` and `[a]`) are both - anonymous, so if we had '(:) 'True '[], then the kinds of 'True and - '[] would contribute to the kind of '(:) 'True '[]. Therefore, - injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. - (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) -* Named binders: - - Inferred binders are never injective positions. For example, in this data - type: - - data Proxy a - Proxy :: forall {k}. k -> Type - - If we had Proxy 'True, then the kind of 'True would not contribute to the - kind of Proxy 'True. Therefore, - injective_vars_of_binder(forall {k}. ...) = {}. - - Required binders are injective positions. For example, in this data type: - - data Wurble k (a :: k) :: k - Wurble :: forall k -> k -> k - - The first tyvar binder (of kind `forall k`) has required visibility, so if - we had Wurble (Maybe a) Nothing, then the kind of Maybe a would - contribute to the kind of Wurble (Maybe a) Nothing. Hence, - injective_vars_of_binder(forall a -> ...) = {a}. - - Specified binders /might/ be injective positions, depending on how you - approach things. Continuing the '(:) example: - - '(:) :: forall a. a -> [a] -> [a] - - Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind - of '(:) 'True '[], since it's not explicitly instantiated by the user. But - if visible kind application is enabled, then this is possible, since the - user can write '(:) @Bool 'True '[]. (In that case, - injective_vars_of_binder(forall a. ...) = {a}.) - - There are some situations where using visible kind application is appropriate - (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH - reification), so the `injective_vars_of_binder` function is parametrized by - a Bool which decides if specified binders should be counted towards - injective positions or not. - -Now that we've defined injective_vars_of_binder, we can refine the Question We -Must Answer once more: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the remainder of T's kind? - -If the answer to this question is "no", then (T ty_1 ... ty_n) needs an -explicit kind signature, since T's kind has kind variables leftover that -aren't fixed by the non-omitted arguments. - -One last sticking point: what does "the remainder of T's kind" mean? You might -be tempted to think that it corresponds to all of the arguments in the kind of -T that would normally be instantiated by omitted arguments. But this isn't -quite right, strictly speaking. Consider the following (silly) example: - - S :: forall {k}. Type -> Type - -And suppose we have this application of S: - - S Int Bool - -The Int argument would be omitted, and -injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which -might suggest that (S Bool) needs an explicit kind signature. But -(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature -only affects the /result/ of the application, not all of the individual -arguments. So adding a kind signature here won't make a difference. Therefore, -the fourth (and final) iteration of the Question We Must Answer is: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the kind of (T ty_1 ... ty_n)? - -Phew, that was a lot of work! - -How can be sure that this is correct? That is, how can we be sure that in the -event that we leave off a kind annotation, that one could infer the kind of the -tycon application from its arguments? It's essentially a proof by induction: if -we can infer the kinds of every subtree of a type, then the whole tycon -application will have an inferrable kind--unless, of course, the remainder of -the tycon application's kind has uninstantiated kind variables. - -What happens if T is oversaturated? That is, if T's kind has fewer than n -arguments, in the case that the concrete application instantiates a result -kind variable with an arrow kind? If we run out of arguments, we do not attach -a kind annotation. This should be a rare case, indeed. Here is an example: - - data T1 :: k1 -> k2 -> * - data T2 :: k1 -> k2 -> * - - type family G (a :: k) :: k - type instance G T1 = T2 - - type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above - -Here G's kind is (forall k. k -> k), and the desugared RHS of that last -instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to -the algorithm above, there are 3 arguments to G so we should peel off 3 -arguments in G's kind. But G's kind has only two arguments. This is the -rare special case, and we choose not to annotate the application of G with -a kind signature. After all, we needn't do this, since that instance would -be reified as: - - type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool - -So the kind of G isn't ambiguous anymore due to the explicit kind annotation -on its argument. See #8953 and test th/T8953. --} diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot deleted file mode 100644 --- a/compiler/types/Type.hs-boot +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Type where - -import GhcPrelude -import TyCon -import {-# SOURCE #-} TyCoRep( Type, Coercion ) -import Util - -isPredTy :: HasDebugCallStack => Type -> Bool -isCoercionTy :: Type -> Bool - -mkAppTy :: Type -> Type -> Type -mkCastTy :: Type -> Coercion -> Type -piResultTy :: HasDebugCallStack => Type -> Type -> Type - -eqType :: Type -> Type -> Bool - -coreView :: Type -> Maybe Type -tcView :: Type -> Maybe Type -isRuntimeRepTy :: Type -> Bool -isLiftedTypeKind :: Type -> Bool - -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) - -partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs deleted file mode 100644 --- a/compiler/types/Unify.hs +++ /dev/null @@ -1,1592 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module Unify ( - tcMatchTy, tcMatchTyKi, - tcMatchTys, tcMatchTyKis, - tcMatchTyX, tcMatchTysX, tcMatchTyKisX, - tcMatchTyX_BM, ruleMatchTyKiX, - - -- * Rough matching - roughMatchTcs, instanceCantMatch, - typesCantMatch, - - -- Side-effect free unification - tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, - tcUnifyTysFG, tcUnifyTyWithTFs, - BindFlag(..), - UnifyResult, UnifyResultM(..), - - -- Matching a type against a lifted type (coercion) - liftCoMatch - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Var -import VarEnv -import VarSet -import Name( Name ) -import Type hiding ( getTvSubstEnv ) -import Coercion hiding ( getCvSubstEnv ) -import TyCon -import TyCoRep -import TyCoFVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) -import TyCoSubst ( mkTvSubst ) -import FV( FV, fvVarSet, fvVarList ) -import Util -import Pair -import Outputable -import UniqFM -import UniqSet - -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import Control.Applicative hiding ( empty ) -import qualified Control.Applicative - -{- - -Unification is much tricker than you might think. - -1. The substitution we generate binds the *template type variables* - which are given to us explicitly. - -2. We want to match in the presence of foralls; - e.g (forall a. t1) ~ (forall b. t2) - - That is what the RnEnv2 is for; it does the alpha-renaming - that makes it as if a and b were the same variable. - Initialising the RnEnv2, so that it can generate a fresh - binder when necessary, entails knowing the free variables of - both types. - -3. We must be careful not to bind a template type variable to a - locally bound variable. E.g. - (forall a. x) ~ (forall b. b) - where x is the template type variable. Then we do not want to - bind x to a/b! This is a kind of occurs check. - The necessary locals accumulate in the RnEnv2. - -Note [tcMatchTy vs tcMatchTyKi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This module offers two variants of matching: with kinds and without. -The TyKi variant takes two types, of potentially different kinds, -and matches them. Along the way, it necessarily also matches their -kinds. The Ty variant instead assumes that the kinds are already -eqType and so skips matching up the kinds. - -How do you choose between them? - -1. If you know that the kinds of the two types are eqType, use - the Ty variant. It is more efficient, as it does less work. - -2. If the kinds of variables in the template type might mention type families, - use the Ty variant (and do other work to make sure the kinds - work out). These pure unification functions do a straightforward - syntactic unification and do no complex reasoning about type - families. Note that the types of the variables in instances can indeed - mention type families, so instance lookup must use the Ty variant. - - (Nothing goes terribly wrong -- no panics -- if there might be type - families in kinds in the TyKi variant. You just might get match - failure even though a reducing a type family would lead to success.) - -3. Otherwise, if you're sure that the variable kinds do not mention - type families and you're not already sure that the kind of the template - equals the kind of the target, then use the TyKi version. --} - --- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) --- @s@ such that @s(t1)@ equals @t2@. --- The returned substitution might bind coercion variables, --- if the variable is an argument to a GADT constructor. --- --- Precondition: typeKind ty1 `eqType` typeKind ty2 --- --- We don't pass in a set of "template variables" to be bound --- by the match, because tcMatchTy (and similar functions) are --- always used on top-level types, so we can bind any of the --- free variables of the LHS. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTy :: Type -> Type -> Maybe TCvSubst -tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] - -tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst - -> Type -> Type -> Maybe TCvSubst -tcMatchTyX_BM bind_me subst ty1 ty2 - = tc_match_tys_x bind_me False subst [ty1] [ty2] - --- | Like 'tcMatchTy', but allows the kinds of the types to differ, --- and thus matches them as well. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKi :: Type -> Type -> Maybe TCvSubst -tcMatchTyKi ty1 ty2 - = tc_match_tys (const BindMe) True [ty1] [ty2] - --- | This is similar to 'tcMatchTy', but extends a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyX :: TCvSubst -- ^ Substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TCvSubst -tcMatchTyX subst ty1 ty2 - = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] - --- | Like 'tcMatchTy' but over a list of types. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTys :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot; in principle the template - -- variables could be free in the target -tcMatchTys tys1 tys2 - = tc_match_tys (const BindMe) False tys1 tys2 - --- | Like 'tcMatchTyKi' but over a list of types. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKis :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTyKis tys1 tys2 - = tc_match_tys (const BindMe) True tys1 tys2 - --- | Like 'tcMatchTys', but extending a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTysX :: TCvSubst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTysX subst tys1 tys2 - = tc_match_tys_x (const BindMe) False subst tys1 tys2 - --- | Like 'tcMatchTyKis', but extending a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTyKisX subst tys1 tys2 - = tc_match_tys_x (const BindMe) True subst tys1 tys2 - --- | Same as tc_match_tys_x, but starts with an empty substitution -tc_match_tys :: (TyVar -> BindFlag) - -> Bool -- ^ match kinds? - -> [Type] - -> [Type] - -> Maybe TCvSubst -tc_match_tys bind_me match_kis tys1 tys2 - = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) - --- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' -tc_match_tys_x :: (TyVar -> BindFlag) - -> Bool -- ^ match kinds? - -> TCvSubst - -> [Type] - -> [Type] - -> Maybe TCvSubst -tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 - = case tc_unify_tys bind_me - False -- Matching, not unifying - False -- Not an injectivity check - match_kis - (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of - Unifiable (tv_env', cv_env') - -> Just $ TCvSubst in_scope tv_env' cv_env' - _ -> Nothing - --- | This one is called from the expression matcher, --- which already has a MatchEnv in hand -ruleMatchTyKiX - :: TyCoVarSet -- ^ template variables - -> RnEnv2 - -> TvSubstEnv -- ^ type substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TvSubstEnv -ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target --- See Note [Kind coercions in Unify] - = case tc_unify_tys (matchBindFun tmpl_tvs) False False - True -- <-- this means to match the kinds - rn_env tenv emptyCvSubstEnv [tmpl] [target] of - Unifiable (tenv', _) -> Just tenv' - _ -> Nothing - -matchBindFun :: TyCoVarSet -> TyVar -> BindFlag -matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem - - -{- ********************************************************************* -* * - Rough matching -* * -********************************************************************* -} - --- See Note [Rough match] field in InstEnv - -roughMatchTcs :: [Type] -> [Maybe Name] -roughMatchTcs tys = map rough tys - where - rough ty - | Just (ty', _) <- splitCastTy_maybe ty = rough ty' - | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) - | otherwise = Nothing - -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot --- possibly be instantiated to actual, nor vice versa; --- False is non-committal -instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as -instanceCantMatch _ _ = False -- Safe - -itemCantMatch :: Maybe Name -> Maybe Name -> Bool -itemCantMatch (Just t) (Just a) = t /= a -itemCantMatch _ _ = False - - -{- -************************************************************************ -* * - GADTs -* * -************************************************************************ - -Note [Pruning dead case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider data T a where - T1 :: T Int - T2 :: T a - - newtype X = MkX Int - newtype Y = MkY Char - - type family F a - type instance F Bool = Int - -Now consider case x of { T1 -> e1; T2 -> e2 } - -The question before the house is this: if I know something about the type -of x, can I prune away the T1 alternative? - -Suppose x::T Char. It's impossible to construct a (T Char) using T1, - Answer = YES we can prune the T1 branch (clearly) - -Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated -to 'Bool', in which case x::T Int, so - ANSWER = NO (clearly) - -We see here that we want precisely the apartness check implemented within -tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely -apart. Note that since we are simply dropping dead code, a conservative test -suffices. --} - --- | Given a list of pairs of types, are any two members of a pair surely --- apart, even after arbitrary type function evaluation and substitution? -typesCantMatch :: [(Type,Type)] -> Bool --- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (uncurry cant_match) prs - where - cant_match :: Type -> Type -> Bool - cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of - SurelyApart -> True - _ -> False - -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [Fine-grained unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- -no substitution to finite types makes these match. But, a substitution to -*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. -Why do we care? Consider these two type family instances: - -type instance F x x = Int -type instance F [y] y = Bool - -If we also have - -type instance Looper = [Looper] - -then the instances potentially overlap. The solution is to use unification -over infinite terms. This is possible (see [1] for lots of gory details), but -a full algorithm is a little more power than we need. Instead, we make a -conservative approximation and just omit the occurs check. - -[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf - -tcUnifyTys considers an occurs-check problem as the same as general unification -failure. - -tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check -failure ("MaybeApart"), or general failure ("SurelyApart"). - -See also #8162. - -It's worth noting that unification in the presence of infinite types is not -complete. This means that, sometimes, a closed type family does not reduce -when it should. See test case indexed-types/should_fail/Overlap15 for an -example. - -Note [The substitution in MaybeApart] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? -Because consider unifying these: - -(a, a, Int) ~ (b, [b], Bool) - -If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we -apply the subst we have so far and discover that we need [b |-> [b]]. Because -this fails the occurs check, we say that the types are MaybeApart (see above -Note [Fine-grained unification]). But, we can't stop there! Because if we -continue, we discover that Int is SurelyApart from Bool, and therefore the -types are apart. This has practical consequences for the ability for closed -type family applications to reduce. See test case -indexed-types/should_compile/Overlap14. - -Note [Unifying with skolems] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we discover that two types unify if and only if a skolem variable is -substituted, we can't properly unify the types. But, that skolem variable -may later be instantiated with a unifyable type. So, we return maybeApart -in these cases. --} - --- | Simple unification of two types; all type variables are bindable --- Precondition: the kinds are already equal -tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TCvSubst - -- A regular one-shot (idempotent) substitution -tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] - --- | Like 'tcUnifyTy', but also unifies the kinds -tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst -tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] - --- | Unify two types, treating type family applications as possibly unifying --- with anything and looking through injective type family applications. --- Precondition: kinds are the same -tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; - -- False <=> do one-way matching. - -- See end of sec 5.2 from the paper - -> Type -> Type -> Maybe TCvSubst --- This algorithm is an implementation of the "Algorithm U" presented in --- the paper "Injective type families for Haskell", Figures 2 and 3. --- The code is incorporated with the standard unifier for convenience, but --- its operation should match the specification in the paper. -tcUnifyTyWithTFs twoWay t1 t2 - = case tc_unify_tys (const BindMe) twoWay True False - rn_env emptyTvSubstEnv emptyCvSubstEnv - [t1] [t2] of - Unifiable (subst, _) -> Just $ maybe_fix subst - MaybeApart (subst, _) -> Just $ maybe_fix subst - -- we want to *succeed* in questionable cases. This is a - -- pre-unification algorithm. - SurelyApart -> Nothing - where - in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] - rn_env = mkRnEnv2 in_scope - - maybe_fix | twoWay = niFixTCvSubst - | otherwise = mkTvSubst in_scope -- when matching, don't confuse - -- domain with range - ------------------ -tcUnifyTys :: (TyCoVar -> BindFlag) - -> [Type] -> [Type] - -> Maybe TCvSubst - -- ^ A regular one-shot (idempotent) substitution - -- that unifies the erased types. See comments - -- for 'tcUnifyTysFG' - --- The two types may have common type variables, and indeed do so in the --- second call to tcUnifyTys in FunDeps.checkClsFD -tcUnifyTys bind_fn tys1 tys2 - = case tcUnifyTysFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- | Like 'tcUnifyTys' but also unifies the kinds -tcUnifyTyKis :: (TyCoVar -> BindFlag) - -> [Type] -> [Type] - -> Maybe TCvSubst -tcUnifyTyKis bind_fn tys1 tys2 - = case tcUnifyTyKisFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- This type does double-duty. It is used in the UM (unifier monad) and to --- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM TCvSubst -data UnifyResultM a = Unifiable a -- the subst that unifies the types - | MaybeApart a -- the subst has as much as we know - -- it must be part of a most general unifier - -- See Note [The substitution in MaybeApart] - | SurelyApart - deriving Functor - -instance Applicative UnifyResultM where - pure = Unifiable - (<*>) = ap - -instance Monad UnifyResultM where - - SurelyApart >>= _ = SurelyApart - MaybeApart x >>= f = case f x of - Unifiable y -> MaybeApart y - other -> other - Unifiable x >>= f = f x - -instance Alternative UnifyResultM where - empty = SurelyApart - - a@(Unifiable {}) <|> _ = a - _ <|> b@(Unifiable {}) = b - a@(MaybeApart {}) <|> _ = a - _ <|> b@(MaybeApart {}) = b - SurelyApart <|> SurelyApart = SurelyApart - -instance MonadPlus UnifyResultM - --- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose --- domain elements all respond 'BindMe' to @bind_tv@) such that --- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned --- Coercions. This version requires that the kinds of the types are the same, --- if you unify left-to-right. -tcUnifyTysFG :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTysFG bind_fn tys1 tys2 - = tc_unify_tys_fg False bind_fn tys1 tys2 - -tcUnifyTyKisFG :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTyKisFG bind_fn tys1 tys2 - = tc_unify_tys_fg True bind_fn tys1 tys2 - -tc_unify_tys_fg :: Bool - -> (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tc_unify_tys_fg match_kis bind_fn tys1 tys2 - = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env - emptyTvSubstEnv emptyCvSubstEnv - tys1 tys2 - ; return $ niFixTCvSubst env } - where - vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 - env = mkRnEnv2 $ mkInScopeSet vars - --- | This function is actually the one to call the unifier -- a little --- too general for outside clients, though. -tc_unify_tys :: (TyVar -> BindFlag) - -> AmIUnifying -- ^ True <=> unify; False <=> match - -> Bool -- ^ True <=> doing an injectivity check - -> Bool -- ^ True <=> treat the kinds as well - -> RnEnv2 - -> TvSubstEnv -- ^ substitution to extend - -> CvSubstEnv - -> [Type] -> [Type] - -> UnifyResultM (TvSubstEnv, CvSubstEnv) --- NB: It's tempting to ASSERT here that, if we're not matching kinds, then --- the kinds of the types should be the same. However, this doesn't work, --- as the types may be a dependent telescope, where later types have kinds --- that mention variables occurring earlier in the list of types. Here's an --- example (from typecheck/should_fail/T12709): --- template: [rep :: RuntimeRep, a :: TYPE rep] --- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] --- We can see that matching the first pair will make the kinds of the second --- pair equal. Yet, we still don't need a separate pass to unify the kinds --- of these types, so it's appropriate to use the Ty variant of unification. --- See also Note [tcMatchTy vs tcMatchTyKi]. -tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 - = initUM tv_env cv_env $ - do { when match_kis $ - unify_tys env kis1 kis2 - ; unify_tys env tys1 tys2 - ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } - where - env = UMEnv { um_bind_fun = bind_fn - , um_skols = emptyVarSet - , um_unif = unif - , um_inj_tf = inj_check - , um_rn_env = rn_env } - - kis1 = map typeKind tys1 - kis2 = map typeKind tys2 - -instance Outputable a => Outputable (UnifyResultM a) where - ppr SurelyApart = text "SurelyApart" - ppr (Unifiable x) = text "Unifiable" <+> ppr x - ppr (MaybeApart x) = text "MaybeApart" <+> ppr x - -{- -************************************************************************ -* * - Non-idempotent substitution -* * -************************************************************************ - -Note [Non-idempotent substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During unification we use a TvSubstEnv/CvSubstEnv pair that is - (a) non-idempotent - (b) loop-free; ie repeatedly applying it yields a fixed point - -Note [Finding the substitution fixpoint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Finding the fixpoint of a non-idempotent substitution arising from a -unification is much trickier than it looks, because of kinds. Consider - T k (H k (f:k)) ~ T * (g:*) -If we unify, we get the substitution - [ k -> * - , g -> H k (f:k) ] -To make it idempotent we don't want to get just - [ k -> * - , g -> H * (f:k) ] -We also want to substitute inside f's kind, to get - [ k -> * - , g -> H k (f:*) ] -If we don't do this, we may apply the substitution to something, -and get an ill-formed type, i.e. one where typeKind will fail. -This happened, for example, in #9106. - -It gets worse. In #14164 we wanted to take the fixpoint of -this substitution - [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) - (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) - , a_aY6 :-> a_aXQ ] - -We have to apply the substitution for a_aY6 two levels deep inside -the invocation of F! We don't have a function that recursively -applies substitutions inside the kinds of variable occurrences (and -probably rightly so). - -So, we work as follows: - - 1. Start with the current substitution (which we are - trying to fixpoint - [ xs :-> F a (z :: a) (rest :: G a (z :: a)) - , a :-> b ] - - 2. Take all the free vars of the range of the substitution: - {a, z, rest, b} - NB: the free variable finder closes over - the kinds of variable occurrences - - 3. If none are in the domain of the substitution, stop. - We have found a fixpoint. - - 4. Remove the variables that are bound by the substitution, leaving - {z, rest, b} - - 5. Do a topo-sort to put them in dependency order: - [ b :: *, z :: a, rest :: G a z ] - - 6. Apply the substitution left-to-right to the kinds of these - tyvars, extending it each time with a new binding, so we - finish up with - [ xs :-> ..as before.. - , a :-> b - , b :-> b :: * - , z :-> z :: b - , rest :-> rest :: G b (z :: b) ] - Note that rest now has the right kind - - 7. Apply this extended substitution (once) to the range of - the /original/ substitution. (Note that we do the - extended substitution would go on forever if you tried - to find its fixpoint, because it maps z to z.) - - 8. And go back to step 1 - -In Step 6 we use the free vars from Step 2 as the initial -in-scope set, because all of those variables appear in the -range of the substitution, so they must all be in the in-scope -set. But NB that the type substitution engine does not look up -variables in the in-scope set; it is used only to ensure no -shadowing. --} - -niFixTCvSubst :: TvSubstEnv -> TCvSubst --- Find the idempotent fixed point of the non-idempotent substitution --- This is surprisingly tricky: --- see Note [Finding the substitution fixpoint] --- ToDo: use laziness instead of iteration? -niFixTCvSubst tenv - | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) - | otherwise = subst - where - range_fvs :: FV - range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) - -- It's OK to use nonDetEltsUFM here because the - -- order of range_fvs, range_tvs is immaterial - - range_tvs :: [TyVar] - range_tvs = fvVarList range_fvs - - not_fixpoint = any in_domain range_tvs - in_domain tv = tv `elemVarEnv` tenv - - free_tvs = scopedSort (filterOut in_domain range_tvs) - - -- See Note [Finding the substitution fixpoint], Step 6 - init_in_scope = mkInScopeSet (fvVarSet range_fvs) - subst = foldl' add_free_tv - (mkTvSubst init_in_scope tenv) - free_tvs - - add_free_tv :: TCvSubst -> TyVar -> TCvSubst - add_free_tv subst tv - = extendTvSubst subst tv (mkTyVarTy tv') - where - tv' = updateTyVarKind (substTy subst) tv - -niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet --- Apply the non-idempotent substitution to a set of type variables, --- remembering that the substitution isn't necessarily idempotent --- This is used in the occurs check, before extending the substitution -niSubstTvSet tsubst tvs - = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs - -- It's OK to nonDetFoldUFM here because we immediately forget the - -- ordering by creating a set. - where - get tv - | Just ty <- lookupVarEnv tsubst tv - = niSubstTvSet tsubst (tyCoVarsOfType ty) - - | otherwise - = unitVarSet tv - -{- -************************************************************************ -* * - unify_ty: the main workhorse -* * -************************************************************************ - -Note [Specification of unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The pure unifier, unify_ty, defined in this module, tries to work out -a substitution to make two types say True to eqType. NB: eqType is -itself not purely syntactic; it accounts for CastTys; -see Note [Non-trivial definitional equality] in TyCoRep - -Unlike the "impure unifiers" in the typechecker (the eager unifier in -TcUnify, and the constraint solver itself in TcCanonical), the pure -unifier It does /not/ work up to ~. - -The algorithm implemented here is rather delicate, and we depend on it -to uphold certain properties. This is a summary of these required -properties. Any reference to "flattening" refers to the flattening -algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not -the flattening algorithm in the solver. - -Notation: - θ,φ substitutions - ξ type-function-free types - τ,σ other types - τ♭ type τ, flattened - - ≡ eqType - -(U1) Soundness. - If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). - θ is a most general unifier for τ₁ and τ₂. - -(U2) Completeness. - If (unify ξ₁ ξ₂) = SurelyApart, - then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). - -These two properties are stated as Property 11 in the "Closed Type Families" -paper (POPL'14). Below, this paper is called [CTF]. - -(U3) Apartness under substitution. - If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, - for any θ. (Property 12 from [CTF]) - -(U4) Apart types do not unify. - If (unify ξ τ♭) = SurelyApart, then there exists no θ - such that θ(ξ) = θ(τ). (Property 13 from [CTF]) - -THEOREM. Completeness w.r.t ~ - If (unify τ₁♭ τ₂♭) = SurelyApart, - then there exists no proof that (τ₁ ~ τ₂). - -PROOF. See appendix of [CTF]. - - -The unification algorithm is used for type family injectivity, as described -in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run -in this mode, it has the following properties. - -(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even - after arbitrary type family reductions. Note that σ and τ are - not flattened here. - -(I2) If (unify σ τ) = MaybeApart θ, and if some - φ exists such that φ(σ) ~ φ(τ), then φ extends θ. - - -Furthermore, the RULES matching algorithm requires this property, -but only when using this algorithm for matching: - -(M1) If (match σ τ) succeeds with θ, then all matchable tyvars - in σ are bound in θ. - - Property M1 means that we must extend the substitution with, - say (a ↦ a) when appropriate during matching. - See also Note [Self-substitution when matching]. - -(M2) Completeness of matching. - If θ(σ) = τ, then (match σ τ) = Unifiable φ, - where θ is an extension of φ. - -Sadly, property M2 and I2 conflict. Consider - -type family F1 a b where - F1 Int Bool = Char - F1 Double String = Char - -Consider now two matching problems: - -P1. match (F1 a Bool) (F1 Int Bool) -P2. match (F1 a Bool) (F1 Double String) - -In case P1, we must find (a ↦ Int) to satisfy M2. -In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note -that the correct mapping for I2 is (a ↦ Int). There is no way to discover -this, but we musn't map a to anything else!) - -We thus must parameterize the algorithm over whether it's being used -for an injectivity check (refrain from looking at non-injective arguments -to type families) or not (do indeed look at those arguments). This is -implemented by the uf_inj_tf field of UmEnv. - -(It's all a question of whether or not to include equation (7) from Fig. 2 -of [ITF].) - -This extra parameter is a bit fiddly, perhaps, but seemingly less so than -having two separate, almost-identical algorithms. - -Note [Self-substitution when matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should happen when we're *matching* (not unifying) a1 with a1? We -should get a substitution [a1 |-> a1]. A successful match should map all -the template variables (except ones that disappear when expanding synonyms). -But when unifying, we don't want to do this, because we'll then fall into -a loop. - -This arrangement affects the code in three places: - - If we're matching a refined template variable, don't recur. Instead, just - check for equality. That is, if we know [a |-> Maybe a] and are matching - (a ~? Maybe Int), we want to just fail. - - - Skip the occurs check when matching. This comes up in two places, because - matching against variables is handled separately from matching against - full-on types. - -Note that this arrangement was provoked by a real failure, where the same -unique ended up in the template as in the target. (It was a rule firing when -compiling Data.List.NonEmpty.) - -Note [Matching coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - type family F a - - data G a where - MkG :: F a ~ Bool => G a - - type family Foo (x :: G a) :: F a - type instance Foo MkG = False - -We would like that to be accepted. For that to work, we need to introduce -a coercion variable on the left and then use it on the right. Accordingly, -at use sites of Foo, we need to be able to use matching to figure out the -value for the coercion. (See the desugared version: - - axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) - -) We never want this action to happen during *unification* though, when -all bets are off. - -Note [Kind coercions in Unify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to match/unify while ignoring casts. But, we can't just ignore -them completely, or we'll end up with ill-kinded substitutions. For example, -say we're matching `a` with `ty |> co`. If we just drop the cast, we'll -return [a |-> ty], but `a` and `ty` might have different kinds. We can't -just match/unify their kinds, either, because this might gratuitously -fail. After all, `co` is the witness that the kinds are the same -- they -may look nothing alike. - -So, we pass a kind coercion to the match/unify worker. This coercion witnesses -the equality between the substed kind of the left-hand type and the substed -kind of the right-hand type. Note that we do not unify kinds at the leaves -(as we did previously). We thus have - -INVARIANT: In the call - unify_ty ty1 ty2 kco -it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where -`subst` is the ambient substitution in the UM monad. - -To get this coercion, we first have to match/unify -the kinds before looking at the types. Happily, we need look only one level -up, as all kinds are guaranteed to have kind *. - -When we're working with type applications (either TyConApp or AppTy) we -need to worry about establishing INVARIANT, as the kinds of the function -& arguments aren't (necessarily) included in the kind of the result. -When unifying two TyConApps, this is easy, because the two TyCons are -the same. Their kinds are thus the same. As long as we unify left-to-right, -we'll be sure to unify types' kinds before the types themselves. (For example, -think about Proxy :: forall k. k -> *. Unifying the first args matches up -the kinds of the second args.) - -For AppTy, we must unify the kinds of the functions, but once these are -unified, we can continue unifying arguments without worrying further about -kinds. - -The interface to this module includes both "...Ty" functions and -"...TyKi" functions. The former assume that INVARIANT is already -established, either because the kinds are the same or because the -list of types being passed in are the well-typed arguments to some -type constructor (see two paragraphs above). The latter take a separate -pre-pass over the kinds to establish INVARIANT. Sometimes, it's important -not to take the second pass, as it caused #12442. - -We thought, at one point, that this was all unnecessary: why should -casts be in types in the first place? But they are sometimes. In -dependent/should_compile/KindEqualities2, we see, for example the -constraint Num (Int |> (blah ; sym blah)). We naturally want to find -a dictionary for that constraint, which requires dealing with -coercions in this manner. - -Note [Matching in the presence of casts (1)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When matching, it is crucial that no variables from the template -end up in the range of the matching substitution (obviously!). -When unifying, that's not a constraint; instead we take the fixpoint -of the substitution at the end. - -So what should we do with this, when matching? - unify_ty (tmpl |> co) tgt kco - -Previously, wrongly, we pushed 'co' in the (horrid) accumulating -'kco' argument like this: - unify_ty (tmpl |> co) tgt kco - = unify_ty tmpl tgt (kco ; co) - -But that is obviously wrong because 'co' (from the template) ends -up in 'kco', which in turn ends up in the range of the substitution. - -This all came up in #13910. Because we match tycon arguments -left-to-right, the ambient substitution will already have a matching -substitution for any kinds; so there is an easy fix: just apply -the substitution-so-far to the coercion from the LHS. - -Note that - -* When matching, the first arg of unify_ty is always the template; - we never swap round. - -* The above argument is distressingly indirect. We seek a - better way. - -* One better way is to ensure that type patterns (the template - in the matching process) have no casts. See #14119. - -Note [Matching in the presence of casts (2)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) -and we are matching - tcMatchTy (T k (a::k)) (T j (b::j)) - -Then we'll match k :-> j, as expected. But then in unify_tys -we invoke - unify_tys env (a::k) (b::j) (Refl j) - -Although we have unified k and j, it's very important that we put -(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. -If we put (Refl k) we'd end up with the substitution - a :-> b |> Refl k -which is bogus because one of the template variables, k, -appears in the range of the substitution. Eek. - -Similar care is needed in unify_ty_app. - - -Note [Polykinded tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose T :: forall k. Type -> K -and we are unifying - ty1: T @Type Int :: Type - ty2: T @(Type->Type) Int Int :: Type - -These two TyConApps have the same TyCon at the front but they -(legitimately) have different numbers of arguments. They -are surelyApart, so we can report that without looking any -further (see #15704). --} - --------------- unify_ty: the main workhorse ----------- - -type AmIUnifying = Bool -- True <=> Unifying - -- False <=> Matching - -unify_ty :: UMEnv - -> Type -> Type -- Types to be unified and a co - -> CoercionN -- A coercion between their kinds - -- See Note [Kind coercions in Unify] - -> UM () --- See Note [Specification of unification] --- Respects newtypes, PredTypes - -unify_ty env ty1 ty2 kco - -- TODO: More commentary needed here - | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco - | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco - | CastTy ty1' co <- ty1 = if um_unif env - then unify_ty env ty1' ty2 (co `mkTransCo` kco) - else -- See Note [Matching in the presence of casts (1)] - do { subst <- getSubst env - ; let co' = substCo subst co - ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } - | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) - -unify_ty env (TyVarTy tv1) ty2 kco - = uVar env tv1 ty2 kco -unify_ty env ty1 (TyVarTy tv2) kco - | um_unif env -- If unifying, can swap args - = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) - -unify_ty env ty1 ty2 _kco - | Just (tc1, tys1) <- mb_tc_app1 - , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) - = if isInjectiveTyCon tc1 Nominal - then unify_tys env tys1 tys2 - else do { let inj | isTypeFamilyTyCon tc1 - = case tyConInjectivityInfo tc1 of - NotInjective -> repeat False - Injective bs -> bs - | otherwise - = repeat False - - (inj_tys1, noninj_tys1) = partitionByList inj tys1 - (inj_tys2, noninj_tys2) = partitionByList inj tys2 - - ; unify_tys env inj_tys1 inj_tys2 - ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] - don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } - - | Just (tc1, _) <- mb_tc_app1 - , not (isGenerativeTyCon tc1 Nominal) - -- E.g. unify_ty (F ty1) b = MaybeApart - -- because the (F ty1) behaves like a variable - -- NB: if unifying, we have already dealt - -- with the 'ty2 = variable' case - = maybeApart - - | Just (tc2, _) <- mb_tc_app2 - , not (isGenerativeTyCon tc2 Nominal) - , um_unif env - -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) - -- because the (F ty2) behaves like a variable - -- NB: we have already dealt with the 'ty1 = variable' case - = maybeApart - - where - mb_tc_app1 = tcSplitTyConApp_maybe ty1 - mb_tc_app2 = tcSplitTyConApp_maybe ty2 - - -- Applications need a bit of care! - -- They can match FunTy and TyConApp, so use splitAppTy_maybe - -- NB: we've already dealt with type variables, - -- so if one type is an App the other one jolly well better be too -unify_ty env (AppTy ty1a ty1b) ty2 _kco - | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty env ty1 (AppTy ty2a ty2b) _kco - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () - -unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco - = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) - ; let env' = umRnBndr2 env tv1 tv2 - ; unify_ty env' ty1 ty2 kco } - --- See Note [Matching coercion variables] -unify_ty env (CoercionTy co1) (CoercionTy co2) kco - = do { c_subst <- getCvSubstEnv - ; case co1 of - CoVarCo cv - | not (um_unif env) - , not (cv `elemVarEnv` c_subst) - , BindMe <- tvBindFlag env cv - -> do { checkRnEnv env (tyCoVarsOfCo co2) - ; let (co_l, co_r) = decomposeFunCo Nominal kco - -- cv :: t1 ~ t2 - -- co2 :: s1 ~ s2 - -- co_l :: t1 ~ s1 - -- co_r :: t2 ~ s2 - ; extendCvEnv cv (co_l `mkTransCo` - co2 `mkTransCo` - mkSymCo co_r) } - _ -> return () } - -unify_ty _ _ _ _ = surelyApart - -unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () -unify_ty_app env ty1 ty1args ty2 ty2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 - = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) - - | otherwise - = do { let ki1 = typeKind ty1 - ki2 = typeKind ty2 - -- See Note [Kind coercions in Unify] - ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) - ; unify_ty env ty1 ty2 (mkNomReflCo ki2) - -- Very important: 'ki2' not 'ki1' - -- See Note [Matching in the presence of casts (2)] - ; unify_tys env ty1args ty2args } - -unify_tys :: UMEnv -> [Type] -> [Type] -> UM () -unify_tys env orig_xs orig_ys - = go orig_xs orig_ys - where - go [] [] = return () - go (x:xs) (y:ys) - -- See Note [Kind coercions in Unify] - = do { unify_ty env x y (mkNomReflCo $ typeKind y) - -- Very important: 'y' not 'x' - -- See Note [Matching in the presence of casts (2)] - ; go xs ys } - go _ _ = surelyApart - -- Possibly different saturations of a polykinded tycon - -- See Note [Polykinded tycon applications] - ---------------------------------- -uVar :: UMEnv - -> InTyVar -- Variable to be unified - -> Type -- with this Type - -> Coercion -- :: kind tv ~N kind ty - -> UM () - -uVar env tv1 ty kco - = do { -- Apply the ambient renaming - let tv1' = umRnOccL env tv1 - - -- Check to see whether tv1 is refined by the substitution - ; subst <- getTvSubstEnv - ; case (lookupVarEnv subst tv1') of - Just ty' | um_unif env -- Unifying, so call - -> unify_ty env ty' ty kco -- back into unify - | otherwise - -> -- Matching, we don't want to just recur here. - -- this is because the range of the subst is the target - -- type, not the template type. So, just check for - -- normal type equality. - guard ((ty' `mkCastTy` kco) `eqType` ty) - Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue - -uUnrefined :: UMEnv - -> OutTyVar -- variable to be unified - -> Type -- with this Type - -> Type -- (version w/ expanded synonyms) - -> Coercion -- :: kind tv ~N kind ty - -> UM () - --- We know that tv1 isn't refined - -uUnrefined env tv1' ty2 ty2' kco - | Just ty2'' <- coreView ty2' - = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms - -- This is essential, in case we have - -- type Foo a = a - -- and then unify a ~ Foo a - - | TyVarTy tv2 <- ty2' - = do { let tv2' = umRnOccR env tv2 - ; unless (tv1' == tv2' && um_unif env) $ do - -- If we are unifying a ~ a, just return immediately - -- Do not extend the substitution - -- See Note [Self-substitution when matching] - - -- Check to see whether tv2 is refined - { subst <- getTvSubstEnv - ; case lookupVarEnv subst tv2 of - { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco - ; _ -> - - do { -- So both are unrefined - -- Bind one or the other, depending on which is bindable - ; let b1 = tvBindFlag env tv1' - b2 = tvBindFlag env tv2' - ty1 = mkTyVarTy tv1' - ; case (b1, b2) of - (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) - (_, BindMe) | um_unif env - -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) - - _ | tv1' == tv2' -> return () - -- How could this happen? If we're only matching and if - -- we're comparing forall-bound variables. - - _ -> maybeApart -- See Note [Unification with skolems] - }}}} - -uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable - = case tvBindFlag env tv1' of - Skolem -> maybeApart -- See Note [Unification with skolems] - BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) - -bindTv :: UMEnv -> OutTyVar -> Type -> UM () --- OK, so we want to extend the substitution with tv := ty --- But first, we must do a couple of checks -bindTv env tv1 ty2 - = do { let free_tvs2 = tyCoVarsOfType ty2 - - -- Make sure tys mentions no local variables - -- E.g. (forall a. b) ~ (forall a. [a]) - -- We should not unify b := [a]! - ; checkRnEnv env free_tvs2 - - -- Occurs check, see Note [Fine-grained unification] - -- Make sure you include 'kco' (which ty2 does) #14846 - ; occurs <- occursCheck env tv1 free_tvs2 - - ; if occurs then maybeApart - else extendTvEnv tv1 ty2 } - -occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool -occursCheck env tv free_tvs - | um_unif env - = do { tsubst <- getTvSubstEnv - ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } - - | otherwise -- Matching; no occurs check - = return False -- See Note [Self-substitution when matching] - -{- -%************************************************************************ -%* * - Binding decisions -* * -************************************************************************ --} - -data BindFlag - = BindMe -- A regular type variable - - | Skolem -- This type variable is a skolem constant - -- Don't bind it; it only matches itself - deriving Eq - -{- -************************************************************************ -* * - Unification monad -* * -************************************************************************ --} - -data UMEnv - = UMEnv { um_unif :: AmIUnifying - - , um_inj_tf :: Bool - -- Checking for injectivity? - -- See (end of) Note [Specification of unification] - - , um_rn_env :: RnEnv2 - -- Renaming InTyVars to OutTyVars; this eliminates - -- shadowing, and lines up matching foralls on the left - -- and right - - , um_skols :: TyVarSet - -- OutTyVars bound by a forall in this unification; - -- Do not bind these in the substitution! - -- See the function tvBindFlag - - , um_bind_fun :: TyVar -> BindFlag - -- User-supplied BindFlag function, - -- for variables not in um_skols - } - -data UMState = UMState - { um_tv_env :: TvSubstEnv - , um_cv_env :: CvSubstEnv } - -newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } - deriving (Functor) - -instance Applicative UM where - pure a = UM (\s -> pure (s, a)) - (<*>) = ap - -instance Monad UM where -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - m >>= k = UM (\state -> - do { (state', v) <- unUM m state - ; unUM (k v) state' }) - --- need this instance because of a use of 'guard' above -instance Alternative UM where - empty = UM (\_ -> Control.Applicative.empty) - m1 <|> m2 = UM (\state -> - unUM m1 state <|> - unUM m2 state) - -instance MonadPlus UM - -instance MonadFail.MonadFail UM where - fail _ = UM (\_ -> SurelyApart) -- failed pattern match - -initUM :: TvSubstEnv -- subst to extend - -> CvSubstEnv - -> UM a -> UnifyResultM a -initUM subst_env cv_subst_env um - = case unUM um state of - Unifiable (_, subst) -> Unifiable subst - MaybeApart (_, subst) -> MaybeApart subst - SurelyApart -> SurelyApart - where - state = UMState { um_tv_env = subst_env - , um_cv_env = cv_subst_env } - -tvBindFlag :: UMEnv -> OutTyVar -> BindFlag -tvBindFlag env tv - | tv `elemVarSet` um_skols env = Skolem - | otherwise = um_bind_fun env tv - -getTvSubstEnv :: UM TvSubstEnv -getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) - -getCvSubstEnv :: UM CvSubstEnv -getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) - -getSubst :: UMEnv -> UM TCvSubst -getSubst env = do { tv_env <- getTvSubstEnv - ; cv_env <- getCvSubstEnv - ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkTCvSubst in_scope (tv_env, cv_env)) } - -extendTvEnv :: TyVar -> Type -> UM () -extendTvEnv tv ty = UM $ \state -> - Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) - -extendCvEnv :: CoVar -> Coercion -> UM () -extendCvEnv cv co = UM $ \state -> - Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) - -umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv -umRnBndr2 env v1 v2 - = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } - where - (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 - -checkRnEnv :: UMEnv -> VarSet -> UM () -checkRnEnv env varset - | isEmptyVarSet skol_vars = return () - | varset `disjointVarSet` skol_vars = return () - | otherwise = maybeApart - -- ToDo: why MaybeApart? - -- I think SurelyApart would be right - where - skol_vars = um_skols env - -- NB: That isEmptyVarSet guard is a critical optimization; - -- it means we don't have to calculate the free vars of - -- the type, often saving quite a bit of allocation. - --- | Converts any SurelyApart to a MaybeApart -don'tBeSoSure :: UM () -> UM () -don'tBeSoSure um = UM $ \ state -> - case unUM um state of - SurelyApart -> MaybeApart (state, ()) - other -> other - -umRnOccL :: UMEnv -> TyVar -> TyVar -umRnOccL env v = rnOccL (um_rn_env env) v - -umRnOccR :: UMEnv -> TyVar -> TyVar -umRnOccR env v = rnOccR (um_rn_env env) v - -umSwapRn :: UMEnv -> UMEnv -umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } - -maybeApart :: UM () -maybeApart = UM (\state -> MaybeApart (state, ())) - -surelyApart :: UM a -surelyApart = UM (\_ -> SurelyApart) - -{- -%************************************************************************ -%* * - Matching a (lifted) type against a coercion -%* * -%************************************************************************ - -This section defines essentially an inverse to liftCoSubst. It is defined -here to avoid a dependency from Coercion on this module. - --} - -data MatchEnv = ME { me_tmpls :: TyVarSet - , me_env :: RnEnv2 } - --- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if --- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, --- where @==@ there means that the result of 'liftCoSubst' has the same --- type as the original co; but may be different under the hood. --- That is, it matches a type against a coercion of the same --- "shape", and returns a lifting substitution which could have been --- used to produce the given coercion from the given type. --- Note that this function is incomplete -- it might return Nothing --- when there does indeed exist a possible lifting context. --- --- This function is incomplete in that it doesn't respect the equality --- in `eqType`. That is, it's possible that this will succeed for t1 and --- fail for t2, even when t1 `eqType` t2. That's because it depends on --- there being a very similar structure between the type and the coercion. --- This incompleteness shouldn't be all that surprising, especially because --- it depends on the structure of the coercion, which is a silly thing to do. --- --- The lifting context produced doesn't have to be exacting in the roles --- of the mappings. This is because any use of the lifting context will --- also require a desired role. Thus, this algorithm prefers mapping to --- nominal coercions where it can do so. -liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext -liftCoMatch tmpls ty co - = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co - ; cenv2 <- ty_co_match menv cenv1 ty co - (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) - ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) - -- Like tcMatchTy, assume all the interesting variables - -- in ty are in tmpls - - ki = typeKind ty - ki_co = promoteCoercion co - ki_ki_co = mkNomReflCo liftedTypeKind - - Pair co_lkind co_rkind = coercionKind ki_co - --- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -- ^ ambient helpful info - -> LiftCoEnv -- ^ incoming subst - -> Type -- ^ ty, type to match - -> Coercion -- ^ co, coercion to match against - -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co - -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co - -> Maybe LiftCoEnv -ty_co_match menv subst ty co lkco rkco - | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco - - -- handle Refl case: - | tyCoVarsOfType ty `isNotInDomainOf` subst - , Just (ty', _) <- isReflCo_maybe co - , ty `eqType` ty' - = Just subst - - where - isNotInDomainOf :: VarSet -> VarEnv a -> Bool - isNotInDomainOf set env - = noneSet (\v -> elemVarEnv v env) set - - noneSet :: (Var -> Bool) -> VarSet -> Bool - noneSet f = allVarSet (not . f) - -ty_co_match menv subst ty co lkco rkco - | CastTy ty' co' <- ty - -- See Note [Matching in the presence of casts (1)] - = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) - substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' - substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' - in - ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) - (substed_co_r `mkTransCo` rkco) - - | SymCo co' <- co - = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco - - -- Match a type variable against a non-refl coercion -ty_co_match menv subst (TyVarTy tv1) co lkco rkco - | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 - = if eqCoercionX (nukeRnEnvL rn_env) co1' co - then Just subst - else Nothing -- no match since tv1 matches two different coercions - - | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var - = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) - then Nothing -- occurs check failed - else Just $ extendVarEnv subst tv1' $ - castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco) - - | otherwise - = Nothing - - where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - - -- just look through SubCo's. We don't really care about roles here. -ty_co_match menv subst ty (SubCo co) lkco rkco - = ty_co_match menv subst ty co lkco rkco - -ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco - | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] -ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - -- yes, the one from Type, not TcType; this is for coercion optimization - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] - -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco - = ty_co_match_tc menv subst tc1 tys tc2 cos -ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco - -- Despite the fact that (->) is polymorphic in four type variables (two - -- runtime rep and two types), we shouldn't need to explicitly unify the - -- runtime reps here; unifying the types themselves should be sufficient. - -- See Note [Representation of function types]. - | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co - , tc == funTyCon - = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] - in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos - -ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) - (ForAllCo tv2 kind_co2 co2) - lkco rkco - | isTyVar tv1 && isTyVar tv2 - = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 - ki_ki_co ki_ki_co - ; let rn_env0 = me_env menv - rn_env1 = rnBndr2 rn_env0 tv1 tv2 - menv' = menv { me_env = rn_env1 } - ; ty_co_match menv' subst1 ty1 co2 lkco rkco } - where - ki_ki_co = mkNomReflCo liftedTypeKind - --- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) --- (ForAllCo cv2 kind_co2 co2) --- lkco rkco --- | isCoVar cv1 && isCoVar cv2 --- We seems not to have enough information for this case --- 1. Given: --- cv1 :: (s1 :: k1) ~r (s2 :: k2) --- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) --- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) --- :: s1' ~ t1 --- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) --- :: s2' ~ t2 --- Wanted: --- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 --- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 --- Question: How do we get kcoi? --- 2. Given: --- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in Type --- rkco :: <*> --- Wanted: --- ty_co_match menv' subst2 ty1 co2 lkco' rkco' --- Question: How do we get lkco' and rkco'? - -ty_co_match _ subst (CoercionTy {}) _ _ _ - = Just subst -- don't inspect coercions - -ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco - = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) - -ty_co_match menv subst ty co1 lkco rkco - | Just (CastTy t co, r) <- isReflCo_maybe co1 - -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us - -- t |> co ~ t ; ; t ~ t |> co - -- But transitive coercions are not helpful. Therefore we deal - -- with it here: we do recursion on the smaller reflexive coercion, - -- while propagating the correct kind coercions. - = let kco' = mkSymCo co - in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') - (rkco `mkTransCo` kco') - - -ty_co_match menv subst ty co lkco rkco - | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco - | otherwise = Nothing - -ty_co_match_tc :: MatchEnv -> LiftCoEnv - -> TyCon -> [Type] - -> TyCon -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_tc menv subst tc1 tys1 tc2 cos2 - = do { guard (tc1 == tc2) - ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } - where - Pair lkcos rkcos - = traverse (fmap mkNomReflCo . coercionKind) cos2 - -ty_co_match_app :: MatchEnv -> LiftCoEnv - -> Type -> [Type] -> Coercion -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_app menv subst ty1 ty1args co2 co2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (co2', co2a) <- splitAppCo_maybe co2 - = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) - - | otherwise - = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co - ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 - ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco - ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args - ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } - where - ki1 = typeKind ty1 - ki2 = promoteCoercion co2 - ki_ki_co = mkNomReflCo liftedTypeKind - -ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] - -> [Coercion] -> [Coercion] -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_args _ subst [] [] _ _ = Just subst -ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) - = do { subst' <- ty_co_match menv subst ty arg lkco rkco - ; ty_co_match_args menv subst' tys args lkcos rkcos } -ty_co_match_args _ _ _ _ _ _ = Nothing - -pushRefl :: Coercion -> Maybe Coercion -pushRefl co = - case (isReflCo_maybe co) of - Just (AppTy ty1 ty2, Nominal) - -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) - Just (FunTy _ ty1 ty2, r) - | Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 - , mkReflCo r ty1, mkReflCo r ty2 ]) - Just (TyConApp tc tys, r) - -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) - Just (ForAllTy (Bndr tv _) ty, r) - -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) - -- NB: NoRefl variant. Otherwise, we get a loop! - _ -> Nothing diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -31,10 +31,8 @@ -- closeBin, seekBin, - seekBy, tellBin, castBin, - isEOFBin, withBinBuffer, writeBinMem, @@ -66,14 +64,14 @@ import GhcPrelude -import {-# SOURCE #-} Name (Name) +import {-# SOURCE #-} GHC.Types.Name (Name) import FastString import PlainPanic -import UniqFM +import GHC.Types.Unique.FM import FastMutInt import Fingerprint -import BasicTypes -import SrcLoc +import GHC.Types.Basic +import GHC.Types.SrcLoc import Foreign import Data.Array @@ -184,21 +182,6 @@ then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p -seekBy :: BinHandle -> Int -> IO () -seekBy h@(BinMem _ ix_r sz_r _) !off = do - sz <- readFastMutInt sz_r - ix <- readFastMutInt ix_r - let ix' = ix + off - if (ix' >= sz) - then do expandBin h ix'; writeFastMutInt ix_r ix' - else writeFastMutInt ix_r ix' - -isEOFBin :: BinHandle -> IO Bool -isEOFBin (BinMem _ ix_r sz_r _) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - return (ix >= sz) - writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode @@ -846,12 +829,10 @@ put_ bh AddrRep = putByte bh 9 put_ bh FloatRep = putByte bh 10 put_ bh DoubleRep = putByte bh 11 -#if __GLASGOW_HASKELL__ >= 807 put_ bh Int8Rep = putByte bh 12 put_ bh Word8Rep = putByte bh 13 put_ bh Int16Rep = putByte bh 14 put_ bh Word16Rep = putByte bh 15 -#endif #if __GLASGOW_HASKELL__ >= 809 put_ bh Int32Rep = putByte bh 16 put_ bh Word32Rep = putByte bh 17 @@ -872,12 +853,10 @@ 9 -> pure AddrRep 10 -> pure FloatRep 11 -> pure DoubleRep -#if __GLASGOW_HASKELL__ >= 807 12 -> pure Int8Rep 13 -> pure Word8Rep 14 -> pure Int16Rep 15 -> pure Word16Rep -#endif #if __GLASGOW_HASKELL__ >= 809 16 -> pure Int32Rep 17 -> pure Word32Rep diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs --- a/compiler/utils/BooleanFormula.hs +++ b/compiler/utils/BooleanFormula.hs @@ -24,9 +24,9 @@ import MonadUtils import Outputable import Binary -import SrcLoc -import Unique -import UniqSet +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Set ---------------------------------------------------------------------- -- Boolean formula type and smart constructors diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs --- a/compiler/utils/Digraph.hs +++ b/compiler/utils/Digraph.hs @@ -58,8 +58,8 @@ import qualified Data.Graph as G import Data.Graph hiding (Graph, Edge, transposeG, reachable) import Data.Tree -import Unique -import UniqFM +import GHC.Types.Unique +import GHC.Types.Unique.FM {- ************************************************************************ diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs --- a/compiler/utils/FV.hs +++ b/compiler/utils/FV.hs @@ -28,8 +28,8 @@ import GhcPrelude -import Var -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Set -- | Predicate on possible free variables: returns @True@ iff the variable is -- interesting @@ -40,7 +40,7 @@ -- When computing free variables, the order in which you get them affects -- the results of floating and specialization. If you use UniqFM to collect -- them and then turn that into a list, you get them in nondeterministic --- order as described in Note [Deterministic UniqFM] in UniqDFM. +-- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -- A naive algorithm for free variables relies on merging sets of variables. -- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log @@ -54,7 +54,7 @@ type VarAcc = ([Var], VarSet) -- List to preserve ordering and set to check for membership, -- so that the list doesn't have duplicates -- For explanation of why using `VarSet` is not deterministic see - -- Note [Deterministic UniqFM] in UniqDFM. + -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -- Note [FV naming conventions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -531,16 +531,22 @@ do r <- memcmp ptr1 ptr2 len return (r == 0) - hashStr :: Ptr Word8 -> Int -> Int -- use the Addr to produce a hash value between 0 & m (inclusive) hashStr (Ptr a#) (I# len#) = loop 0# 0# - where - loop h n | isTrue# (n ==# len#) = I# h - | otherwise = loop h2 (n +# 1#) - where - !c = ord# (indexCharOffAddr# a# n) - !h2 = (h *# 16777619#) `xorI#` c + where + loop h n = + if isTrue# (n ==# len#) then + I# h + else + let + -- DO NOT move this let binding! indexCharOffAddr# reads from the + -- pointer so we need to evaluate this based on the length check + -- above. Not doing this right caused #17909. + !c = ord# (indexCharOffAddr# a# n) + !h2 = (h *# 16777619#) `xorI#` c + in + loop h2 (n +# 1#) -- ----------------------------------------------------------------------------- -- Operations diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs --- a/compiler/utils/FastStringEnv.hs +++ b/compiler/utils/FastStringEnv.hs @@ -29,14 +29,14 @@ import GhcPrelude -import UniqFM -import UniqDFM +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import Maybes import FastString -- | A non-deterministic set of FastStrings. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not -- deterministic and why it matters. Use DFastStringEnv if the set eventually -- gets converted into a list or folded over in a way where the order -- changes the generated code. @@ -82,7 +82,7 @@ lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) -- Deterministic FastStringEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need -- DFastStringEnv. type DFastStringEnv a = UniqDFM a -- Domain is FastString diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -35,7 +35,7 @@ import GHC.Driver.Session import Exception -import Module +import GHC.Types.Module import Panic import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, @@ -43,7 +43,6 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( fixIO ) import Control.Monad -import qualified Control.Monad.Fail as MonadFail import MonadUtils import Control.Applicative (Alternative(..)) @@ -60,11 +59,8 @@ instance Monad (IOEnv m) where (>>=) = thenM (>>) = (*>) -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif -instance MonadFail.MonadFail (IOEnv m) where +instance MonadFail (IOEnv m) where fail _ = failM -- Ignore the string instance Applicative (IOEnv m) where diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -88,7 +88,7 @@ zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) {-# INLINABLE zipWithAndUnzipM #-} --- See Note [flatten_many performance] in TcFlatten for why this +-- See Note [flatten_args performance] in TcFlatten for why this -- pragma is essential. zipWithAndUnzipM f (x:xs) (y:ys) = do { (c, d) <- f x y diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -71,7 +71,7 @@ neverQualify, neverQualifyNames, neverQualifyModules, alwaysQualifyPackages, neverQualifyPackages, QualifyName(..), queryQual, - sdocWithDynFlags, sdocWithPlatform, sdocOption, + sdocWithDynFlags, sdocOption, updSDocContext, SDocContext (..), sdocWithContext, getPprStyle, withPprStyle, setStyleColoured, @@ -96,17 +96,16 @@ import {-# SOURCE #-} GHC.Driver.Session ( DynFlags, hasPprDebug, hasNoDebugOutput - , targetPlatform, pprUserLength, pprCols + , pprUserLength, pprCols , unsafeGlobalDynFlags, initSDocContext ) -import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) -import {-# SOURCE #-} OccName( OccName ) +import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName ) +import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import BufWrite (BufHandle) import FastString import qualified Pretty import Util -import GHC.Platform import qualified PprColour as Col import Pretty ( Doc, Mode(..) ) import Panic @@ -346,7 +345,6 @@ -- ^ True if Unicode encoding is supported -- and not disable by GHC_NO_UNICODE environment variable , sdocHexWordLiterals :: !Bool - , sdocDebugLevel :: !Int , sdocPprDebug :: !Bool , sdocPrintUnicodeSyntax :: !Bool , sdocPrintCaseAsLet :: !Bool @@ -421,9 +419,6 @@ sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx - -sdocWithPlatform :: (Platform -> SDoc) -> SDoc -sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) sdocWithContext :: (SDocContext -> SDoc) -> SDoc sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx diff --git a/compiler/utils/TrieMap.hs b/compiler/utils/TrieMap.hs --- a/compiler/utils/TrieMap.hs +++ b/compiler/utils/TrieMap.hs @@ -31,9 +31,9 @@ import GhcPrelude -import Literal -import UniqDFM -import Unique( Unique ) +import GHC.Types.Literal +import GHC.Types.Unique.DFM +import GHC.Types.Unique( Unique ) import qualified Data.Map as Map import qualified Data.IntMap as IntMap @@ -198,7 +198,7 @@ conversion to a bag to be deterministic. For that purpose we use UniqDFM instead of UniqFM to implement the TrieMap. -See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made +See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made deterministic. -} diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs deleted file mode 100644 --- a/compiler/utils/UniqDFM.hs +++ /dev/null @@ -1,420 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook, 2015 - -UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -This is very similar to @UniqFM@, the major difference being that the order of -folding is not dependent on @Unique@ ordering, giving determinism. -Currently the ordering is determined by insertion order. - -See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering -is not deterministic. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqDFM ( - -- * Unique-keyed deterministic mappings - UniqDFM, -- abstract type - - -- ** Manipulating those mappings - emptyUDFM, - unitUDFM, - addToUDFM, - addToUDFM_C, - addListToUDFM, - delFromUDFM, - delListFromUDFM, - adjustUDFM, - alterUDFM, - mapUDFM, - plusUDFM, - plusUDFM_C, - lookupUDFM, lookupUDFM_Directly, - elemUDFM, - foldUDFM, - eltsUDFM, - filterUDFM, filterUDFM_Directly, - isNullUDFM, - sizeUDFM, - intersectUDFM, udfmIntersectUFM, - intersectsUDFM, - disjointUDFM, disjointUdfmUfm, - equalKeysUDFM, - minusUDFM, - listToUDFM, - udfmMinusUFM, - partitionUDFM, - anyUDFM, allUDFM, - pprUniqDFM, pprUDFM, - - udfmToList, - udfmToUfm, - nonDetFoldUDFM, - alwaysUnsafeUfmToUdfm, - ) where - -import GhcPrelude - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import Data.Data -import Data.Functor.Classes (Eq1 (..)) -import Data.List (sortBy) -import Data.Function (on) -import qualified Data.Semigroup as Semi -import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) - --- Note [Deterministic UniqFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- A @UniqDFM@ is just like @UniqFM@ with the following additional --- property: the function `udfmToList` returns the elements in some --- deterministic order not depending on the Unique key for those elements. --- --- If the client of the map performs operations on the map in deterministic --- order then `udfmToList` returns them in deterministic order. --- --- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts it's result by this serial --- number. So you should only use `UniqDFM` if you need the deterministic --- property. --- --- `foldUDFM` also preserves determinism. --- --- Normal @UniqFM@ when you turn it into a list will use --- Data.IntMap.toList function that returns the elements in the order of --- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with --- with a list ordered by @Uniques@. --- The order of @Uniques@ is known to be not stable across rebuilds. --- See Note [Unique Determinism] in Unique. --- --- --- There's more than one way to implement this. The implementation here tags --- every value with the insertion time that can later be used to sort the --- values when asked to convert to a list. --- --- An alternative would be to have --- --- data UniqDFM ele = UDFM (M.IntMap ele) [ele] --- --- where the list determines the order. This makes deletion tricky as we'd --- only accumulate elements in that list, but makes merging easier as you --- can just merge both structures independently. --- Deletion can probably be done in amortized fashion when the size of the --- list is twice the size of the set. - --- | A type of values tagged with insertion time -data TaggedVal val = - TaggedVal - val - {-# UNPACK #-} !Int -- ^ insertion time - deriving (Data, Functor) - -taggedFst :: TaggedVal val -> val -taggedFst (TaggedVal v _) = v - -taggedSnd :: TaggedVal val -> Int -taggedSnd (TaggedVal _ i) = i - -instance Eq val => Eq (TaggedVal val) where - (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 - --- | Type of unique deterministic finite maps -data UniqDFM ele = - UDFM - !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and - -- values are tagged with insertion time. - -- The invariant is that all the tags will - -- be distinct within a single map - {-# UNPACK #-} !Int -- Upper bound on the values' insertion - -- time. See Note [Overflow on plusUDFM] - deriving (Data, Functor) - --- | Deterministic, in O(n log n). -instance Foldable UniqDFM where - foldr = foldUDFM - --- | Deterministic, in O(n log n). -instance Traversable UniqDFM where - traverse f = fmap listToUDFM_Directly - . traverse (\(u,a) -> (u,) <$> f a) - . udfmToList - -emptyUDFM :: UniqDFM elt -emptyUDFM = UDFM M.empty 0 - -unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt -unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 - --- The new binding always goes to the right of existing ones -addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt -addToUDFM m k v = addToUDFM_Directly m (getUnique k) v - --- The new binding always goes to the right of existing ones -addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt -addToUDFM_Directly (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i - -- Keep the old tag, but insert the new value - -- This means that udfmToList typically returns elements - -- in the order of insertion, rather than the reverse - -addToUDFM_Directly_C - :: (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt - -> Unique -> elt - -> UniqDFM elt -addToUDFM_Directly_C f (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal old_v old_i) - = TaggedVal (f old_v new_v) old_i - -- Flip the arguments, because M.insertWith uses (new->old->result) - -- but f needs (old->new->result) - -- Like addToUDFM_Directly, keep the old tag - -addToUDFM_C - :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt -- old - -> key -> elt -- new - -> UniqDFM elt -- result -addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v - -addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt -addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) - -addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) - -addListToUDFM_Directly_C - :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) - -delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt -delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i - -plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft_C f udfml udfmr - | otherwise = insertUDFMIntoLeft_C f udfmr udfml - --- Note [Overflow on plusUDFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- There are multiple ways of implementing plusUDFM. --- The main problem that needs to be solved is overlap on times of --- insertion between different keys in two maps. --- Consider: --- --- A = fromList [(a, (x, 1))] --- B = fromList [(b, (y, 1))] --- --- If you merge them naively you end up with: --- --- C = fromList [(a, (x, 1)), (b, (y, 1))] --- --- Which loses information about ordering and brings us back into --- non-deterministic world. --- --- The solution I considered before would increment the tags on one of the --- sets by the upper bound of the other set. The problem with this approach --- is that you'll run out of tags for some merge patterns. --- Say you start with A with upper bound 1, you merge A with A to get A' and --- the upper bound becomes 2. You merge A' with A' and the upper bound --- doubles again. After 64 merges you overflow. --- This solution would have the same time complexity as plusUFM, namely O(n+m). --- --- The solution I ended up with has time complexity of --- O(m log m + m * min (n+m, W)) where m is the smaller set. --- It simply inserts the elements of the smaller set into the larger --- set in the order that they were inserted into the smaller set. That's --- O(m log m) for extracting the elements from the smaller set in the --- insertion order and O(m * min(n+m, W)) to insert them into the bigger --- set. - -plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft udfml udfmr - | otherwise = insertUDFMIntoLeft udfmr udfml - -insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr - -insertUDFMIntoLeft_C - :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft_C f udfml udfmr = - addListToUDFM_Directly_C f udfml $ udfmToList udfmr - -lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt -lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m - -lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt -lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m - -elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool -elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m - --- | Performs a deterministic fold over the UniqDFM. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -foldUDFM k z m = foldr k z (eltsUDFM m) - --- | Performs a nondeterministic fold over the UniqDFM. --- It's O(n), same as the corresponding function on `UniqFM`. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m - -eltsUDFM :: UniqDFM elt -> [elt] -eltsUDFM (UDFM m _i) = - map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m - -filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i - -filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i - where - p' k (TaggedVal v _) = p (getUnique k) v - --- | Converts `UniqDFM` to a list, with elements in deterministic order. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -udfmToList :: UniqDFM elt -> [(Unique, elt)] -udfmToList (UDFM m _i) = - [ (getUnique k, taggedFst v) - | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] - --- Determines whether two 'UniqDFM's contain the same keys. -equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool -equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 - -isNullUDFM :: UniqDFM elt -> Bool -isNullUDFM (UDFM m _) = M.null m - -sizeUDFM :: UniqDFM elt -> Int -sizeUDFM (UDFM m _i) = M.size m - -intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) - -disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) - -disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool -disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) - -minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 -minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - -udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - --- | Partition UniqDFM into two UniqDFMs according to the predicate -partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) -partitionUDFM p (UDFM m i) = - case M.partition (p . taggedFst) m of - (left, right) -> (UDFM left i, UDFM right i) - --- | Delete a list of elements from a UniqDFM -delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt -delListFromUDFM = foldl' delFromUDFM - --- | This allows for lossy conversion from UniqDFM to UniqFM -udfmToUfm :: UniqDFM elt -> UniqFM elt -udfmToUfm (UDFM m _i) = - listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] - -listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt -listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM - -listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt -listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM - --- | Apply a function to a particular element -adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt -adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i - --- | The expression (alterUDFM f k map) alters value x at k, or absence --- thereof. alterUDFM can be used to insert, delete, or update a value in --- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are --- more efficient. -alterUDFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqDFM elt -- old - -> key -- new - -> UniqDFM elt -- result -alterUDFM f (UDFM m i) k = - UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) - where - alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) - inject Nothing = Nothing - inject (Just v) = Just $ TaggedVal v i - --- | Map a function over every value in a UniqDFM -mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 -mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i - -anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m - -allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m - -instance Semi.Semigroup (UniqDFM a) where - (<>) = plusUDFM - -instance Monoid (UniqDFM a) where - mempty = emptyUDFM - mappend = (Semi.<>) - --- This should not be used in committed code, provided for convenience to --- make ad-hoc conversions when developing -alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt -alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList - --- Output-ery - -instance Outputable a => Outputable (UniqDFM a) where - ppr ufm = pprUniqDFM ppr ufm - -pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc -pprUniqDFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- udfmToList ufm ] - -pprUDFM :: UniqDFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs deleted file mode 100644 --- a/compiler/utils/UniqDSet.hs +++ /dev/null @@ -1,141 +0,0 @@ --- (c) Bartosz Nitka, Facebook, 2015 - --- | --- Specialised deterministic sets, for things with @Uniques@ --- --- Based on 'UniqDFM's (as you would expect). --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it. --- --- Basically, the things need to be in class 'Uniquable'. - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqDSet ( - -- * Unique set type - UniqDSet, -- type synonym for UniqFM a - getUniqDSet, - pprUniqDSet, - - -- ** Manipulating these sets - delOneFromUniqDSet, delListFromUniqDSet, - emptyUniqDSet, - unitUniqDSet, - mkUniqDSet, - addOneToUniqDSet, addListToUniqDSet, - unionUniqDSets, unionManyUniqDSets, - minusUniqDSet, uniqDSetMinusUniqSet, - intersectUniqDSets, uniqDSetIntersectUniqSet, - foldUniqDSet, - elementOfUniqDSet, - filterUniqDSet, - sizeUniqDSet, - isEmptyUniqDSet, - lookupUniqDSet, - uniqDSetToList, - partitionUniqDSet, - mapUniqDSet - ) where - -import GhcPrelude - -import Outputable -import UniqDFM -import UniqSet -import Unique - -import Data.Coerce -import Data.Data -import qualified Data.Semigroup as Semi - --- See Note [UniqSet invariant] in UniqSet.hs for why we want a newtype here. --- Beyond preserving invariants, we may also want to 'override' typeclass --- instances. - -newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} - deriving (Data, Semi.Semigroup, Monoid) - -emptyUniqDSet :: UniqDSet a -emptyUniqDSet = UniqDSet emptyUDFM - -unitUniqDSet :: Uniquable a => a -> UniqDSet a -unitUniqDSet x = UniqDSet (unitUDFM x x) - -mkUniqDSet :: Uniquable a => [a] -> UniqDSet a -mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet - --- The new element always goes to the right of existing ones. -addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) - -addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -addListToUniqDSet = foldl' addOneToUniqDSet - -delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s - -delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s - -unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) - -unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a -unionManyUniqDSets [] = emptyUniqDSet -unionManyUniqDSets sets = foldr1 unionUniqDSets sets - -minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a -minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) - -uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a -uniqDSetMinusUniqSet xs ys - = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) - -intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) - -uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a -uniqDSetIntersectUniqSet xs ys - = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) - -foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b -foldUniqDSet c n (UniqDSet s) = foldUDFM c n s - -elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool -elementOfUniqDSet k = elemUDFM k . getUniqDSet - -filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a -filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) - -sizeUniqDSet :: UniqDSet a -> Int -sizeUniqDSet = sizeUDFM . getUniqDSet - -isEmptyUniqDSet :: UniqDSet a -> Bool -isEmptyUniqDSet = isNullUDFM . getUniqDSet - -lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a -lookupUniqDSet = lookupUDFM . getUniqDSet - -uniqDSetToList :: UniqDSet a -> [a] -uniqDSetToList = eltsUDFM . getUniqDSet - -partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) -partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet - --- See Note [UniqSet invariant] in UniqSet.hs -mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList - --- Two 'UniqDSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqDSet a) where - UniqDSet a == UniqDSet b = equalKeysUDFM a b - -getUniqDSet :: UniqDSet a -> UniqDFM a -getUniqDSet = getUniqDSet' - -instance Outputable a => Outputable (UniqDSet a) where - ppr = pprUniqDSet ppr - -pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc -pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs deleted file mode 100644 --- a/compiler/utils/UniqFM.hs +++ /dev/null @@ -1,416 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -UniqFM: Specialised finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -(A similar thing to @UniqSet@, as opposed to @Set@.) - -The interface is based on @FiniteMap@s, but the implementation uses -@Data.IntMap@, which is both maintained and faster than the past -implementation (see commit log). - -The @UniqFM@ interface maps directly to Data.IntMap, only -``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased -and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order -of arguments of combining function. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqFM ( - -- * Unique-keyed mappings - UniqFM, -- abstract type - NonDetUniqFM(..), -- wrapper for opting into nondeterminism - - -- ** Manipulating those mappings - emptyUFM, - unitUFM, - unitDirectlyUFM, - listToUFM, - listToUFM_Directly, - listToUFM_C, - addToUFM,addToUFM_C,addToUFM_Acc, - addListToUFM,addListToUFM_C, - addToUFM_Directly, - addListToUFM_Directly, - adjustUFM, alterUFM, - adjustUFM_Directly, - delFromUFM, - delFromUFM_Directly, - delListFromUFM, - delListFromUFM_Directly, - plusUFM, - plusUFM_C, - plusUFM_CD, - plusMaybeUFM_C, - plusUFMList, - minusUFM, - intersectUFM, - intersectUFM_C, - disjointUFM, - equalKeysUFM, - nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, - anyUFM, allUFM, seqEltsUFM, - mapUFM, mapUFM_Directly, - elemUFM, elemUFM_Directly, - filterUFM, filterUFM_Directly, partitionUFM, - sizeUFM, - isNullUFM, - lookupUFM, lookupUFM_Directly, - lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - nonDetEltsUFM, eltsUFM, nonDetKeysUFM, - ufmToSet_Directly, - nonDetUFMToList, ufmToIntMap, - pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM - ) where - -import GhcPrelude - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import qualified Data.IntSet as S -import Data.Data -import qualified Data.Semigroup as Semi -import Data.Functor.Classes (Eq1 (..)) - - -newtype UniqFM ele = UFM (M.IntMap ele) - deriving (Data, Eq, Functor) - -- Nondeterministic Foldable and Traversable instances are accessible through - -- use of the 'NonDetUniqFM' wrapper. - -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. - -emptyUFM :: UniqFM elt -emptyUFM = UFM M.empty - -isNullUFM :: UniqFM elt -> Bool -isNullUFM (UFM m) = M.null m - -unitUFM :: Uniquable key => key -> elt -> UniqFM elt -unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) - --- when you've got the Unique already -unitDirectlyUFM :: Unique -> elt -> UniqFM elt -unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) - -listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt -listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM - -listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt -listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM - -listToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> [(key, elt)] - -> UniqFM elt -listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM - -addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt -addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) - -addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt -addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) - -addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt -addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) - -addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt -addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) - -addToUFM_C - :: Uniquable key - => (elt -> elt -> elt) -- old -> new -> result - -> UniqFM elt -- old - -> key -> elt -- new - -> UniqFM elt -- result --- Arguments of combining function of M.insertWith and addToUFM_C are flipped. -addToUFM_C f (UFM m) k v = - UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) - -addToUFM_Acc - :: Uniquable key - => (elt -> elts -> elts) -- Add to existing - -> (elt -> elts) -- New element - -> UniqFM elts -- old - -> key -> elt -- new - -> UniqFM elts -- result -addToUFM_Acc exi new (UFM m) k v = - UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) - -alterUFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqFM elt -- old - -> key -- new - -> UniqFM elt -- result -alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) - -addListToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> UniqFM elt -> [(key,elt)] - -> UniqFM elt -addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) - -adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt -adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) - -adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt -adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) - -delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt -delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) - -delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt -delListFromUFM = foldl' delFromUFM - -delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt -delListFromUFM_Directly = foldl' delFromUFM_Directly - -delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt -delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) - --- Bindings in right argument shadow those in the left -plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt --- M.union is left-biased, plusUFM should be right-biased. -plusUFM (UFM x) (UFM y) = UFM (M.union y x) - -- Note (M.union y x), with arguments flipped - -- M.union is left-biased, plusUFM should be right-biased. - -plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) - --- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the --- combinding function and `d1` resp. `d2` as the default value if --- there is no entry in `m1` reps. `m2`. The domain is the union of --- the domains of `m1` and `m2`. --- --- Representative example: --- --- @ --- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 --- == {A: f 1 42, B: f 2 3, C: f 23 4 } --- @ -plusUFM_CD - :: (elt -> elt -> elt) - -> UniqFM elt -- map X - -> elt -- default for X - -> UniqFM elt -- map Y - -> elt -- default for Y - -> UniqFM elt -plusUFM_CD f (UFM xm) dx (UFM ym) dy - = UFM $ M.mergeWithKey - (\_ x y -> Just (x `f` y)) - (M.map (\x -> x `f` dy)) - (M.map (\y -> dx `f` y)) - xm ym - -plusMaybeUFM_C :: (elt -> elt -> Maybe elt) - -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusMaybeUFM_C f (UFM xm) (UFM ym) - = UFM $ M.mergeWithKey - (\_ x y -> x `f` y) - id - id - xm ym - -plusUFMList :: [UniqFM elt] -> UniqFM elt -plusUFMList = foldl' plusUFM emptyUFM - -minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -minusUFM (UFM x) (UFM y) = UFM (M.difference x y) - -intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) - -intersectUFM_C - :: (elt1 -> elt2 -> elt3) - -> UniqFM elt1 - -> UniqFM elt2 - -> UniqFM elt3 -intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) - -disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool -disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) - -foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -foldUFM k z (UFM m) = M.foldr k z m - -mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM f (UFM m) = UFM (M.map f m) - -mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) - -filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM p (UFM m) = UFM (M.filter p m) - -filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) - -partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) -partitionUFM p (UFM m) = - case M.partition p m of - (left, right) -> (UFM left, UFM right) - -sizeUFM :: UniqFM elt -> Int -sizeUFM (UFM m) = M.size m - -elemUFM :: Uniquable key => key -> UniqFM elt -> Bool -elemUFM k (UFM m) = M.member (getKey $ getUnique k) m - -elemUFM_Directly :: Unique -> UniqFM elt -> Bool -elemUFM_Directly u (UFM m) = M.member (getKey u) m - -lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt -lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m - --- when you've got the Unique already -lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt -lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m - -lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt -lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m - -lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt -lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m - -eltsUFM :: UniqFM elt -> [elt] -eltsUFM (UFM m) = M.elems m - -ufmToSet_Directly :: UniqFM elt -> S.IntSet -ufmToSet_Directly (UFM m) = M.keysSet m - -anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool -anyUFM p (UFM m) = M.foldr ((||) . p) False m - -allUFM :: (elt -> Bool) -> UniqFM elt -> Bool -allUFM p (UFM m) = M.foldr ((&&) . p) True m - -seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () -seqEltsUFM seqList = seqList . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because the type guarantees that - -- the only interesting thing this function can do is to force the - -- elements. - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUFM :: UniqFM elt -> [elt] -nonDetEltsUFM (UFM m) = M.elems m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUFM :: UniqFM elt -> [Unique] -nonDetKeysUFM (UFM m) = map getUnique $ M.keys m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM k z (UFM m) = M.foldr k z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] -nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m - --- | A wrapper around 'UniqFM' with the sole purpose of informing call sites --- that the provided 'Foldable' and 'Traversable' instances are --- nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } - deriving (Functor) - --- | Inherently nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -instance Foldable NonDetUniqFM where - foldr f z (NonDetUniqFM (UFM m)) = foldr f z m - --- | Inherently nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -instance Traversable NonDetUniqFM where - traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m - -ufmToIntMap :: UniqFM elt -> M.IntMap elt -ufmToIntMap (UFM m) = m - --- Determines whether two 'UniqFM's contain the same keys. -equalKeysUFM :: UniqFM a -> UniqFM b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 - --- Instances - -instance Semi.Semigroup (UniqFM a) where - (<>) = plusUFM - -instance Monoid (UniqFM a) where - mempty = emptyUFM - mappend = (Semi.<>) - --- Output-ery - -instance Outputable a => Outputable (UniqFM a) where - ppr ufm = pprUniqFM ppr ufm - -pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc -pprUniqFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- nonDetUFMToList ufm ] - -- It's OK to use nonDetUFMToList here because we only use it for - -- pretty-printing. - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. -pprUFM :: UniqFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFM ufm pp = pp (nonDetEltsUFM ufm) - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetUFMToList. -pprUFMWithKeys - :: UniqFM a -- ^ The things to be pretty printed - -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralUFM :: UniqFM a -> SDoc -pluralUFM ufm - | sizeUFM ufm == 1 = empty - | otherwise = char 's' diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs deleted file mode 100644 --- a/compiler/utils/UniqSet.hs +++ /dev/null @@ -1,195 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[UniqSet]{Specialised sets, for things with @Uniques@} - -Based on @UniqFMs@ (as you would expect). - -Basically, the things need to be in class @Uniquable@. --} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqSet ( - -- * Unique set type - UniqSet, -- type synonym for UniqFM a - getUniqSet, - pprUniqSet, - - -- ** Manipulating these sets - emptyUniqSet, - unitUniqSet, - mkUniqSet, - addOneToUniqSet, addListToUniqSet, - delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, - delListFromUniqSet_Directly, - unionUniqSets, unionManyUniqSets, - minusUniqSet, uniqSetMinusUFM, - intersectUniqSets, - restrictUniqSetToUFM, - uniqSetAny, uniqSetAll, - elementOfUniqSet, - elemUniqSet_Directly, - filterUniqSet, - filterUniqSet_Directly, - sizeUniqSet, - isEmptyUniqSet, - lookupUniqSet, - lookupUniqSet_Directly, - partitionUniqSet, - mapUniqSet, - unsafeUFMToUniqSet, - nonDetEltsUniqSet, - nonDetKeysUniqSet, - nonDetFoldUniqSet, - nonDetFoldUniqSet_Directly - ) where - -import GhcPrelude - -import UniqFM -import Unique -import Data.Coerce -import Outputable -import Data.Data -import qualified Data.Semigroup as Semi - --- Note [UniqSet invariant] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- UniqSet has the following invariant: --- The keys in the map are the uniques of the values --- It means that to implement mapUniqSet you have to update --- both the keys and the values. - -newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} - deriving (Data, Semi.Semigroup, Monoid) - -emptyUniqSet :: UniqSet a -emptyUniqSet = UniqSet emptyUFM - -unitUniqSet :: Uniquable a => a -> UniqSet a -unitUniqSet x = UniqSet $ unitUFM x x - -mkUniqSet :: Uniquable a => [a] -> UniqSet a -mkUniqSet = foldl' addOneToUniqSet emptyUniqSet - -addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) - -addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -addListToUniqSet = foldl' addOneToUniqSet - -delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) - -delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a -delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) - -delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) - -delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a -delListFromUniqSet_Directly (UniqSet s) l = - UniqSet (delListFromUFM_Directly s l) - -unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) - -unionManyUniqSets :: [UniqSet a] -> UniqSet a -unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet - -minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a -minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) - -intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) - -restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a -restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) - -uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a -uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) - -elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool -elementOfUniqSet a (UniqSet s) = elemUFM a s - -elemUniqSet_Directly :: Unique -> UniqSet a -> Bool -elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s - -filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a -filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) - -filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt -filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) - -partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) -partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) - -uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAny p (UniqSet s) = anyUFM p s - -uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAll p (UniqSet s) = allUFM p s - -sizeUniqSet :: UniqSet a -> Int -sizeUniqSet (UniqSet s) = sizeUFM s - -isEmptyUniqSet :: UniqSet a -> Bool -isEmptyUniqSet (UniqSet s) = isNullUFM s - -lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b -lookupUniqSet (UniqSet s) k = lookupUFM s k - -lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a -lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUniqSet :: UniqSet elt -> [elt] -nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUniqSet :: UniqSet elt -> [Unique] -nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a -nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a -nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s - --- See Note [UniqSet invariant] -mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b -mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet - --- Two 'UniqSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqSet a) where - UniqSet a == UniqSet b = equalKeysUFM a b - -getUniqSet :: UniqSet a -> UniqFM a -getUniqSet = getUniqSet' - --- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ --- assuming, without checking, that it maps each 'Unique' to a value --- that has that 'Unique'. See Note [UniqSet invariant]. -unsafeUFMToUniqSet :: UniqFM a -> UniqSet a -unsafeUFMToUniqSet = UniqSet - -instance Outputable a => Outputable (UniqSet a) where - ppr = pprUniqSet ppr - -pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc --- It's OK to use nonDetUFMToList here because we only use it for --- pretty-printing. -pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -13,7 +13,6 @@ module Util ( -- * Flags dependent on the compiler build ghciSupported, debugIsOn, - ghciTablesNextToCode, isWindowsHost, isDarwinHost, -- * Miscellaneous higher-order functions @@ -203,13 +202,6 @@ debugIsOn = False #endif -ghciTablesNextToCode :: Bool -#if defined(GHCI_TABLES_NEXT_TO_CODE) -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif - isWindowsHost :: Bool #if defined(mingw32_HOST_OS) isWindowsHost = True @@ -577,13 +569,13 @@ -- Debugging/specialising versions of \tr{elem} and \tr{notElem} -isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool - # if !defined(DEBUG) +isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool isIn _msg x ys = x `elem` ys isn'tIn _msg x ys = x `notElem` ys # else /* DEBUG */ +isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool isIn msg x ys = elem100 0 x ys where diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser -version: 0.20200301 +version: 0.20200401 license: BSD3 license-file: LICENSE category: Development @@ -121,6 +121,7 @@ UnboxedTuples UndecidableInstances c-sources: + libraries/ghc-heap/cbits/HeapPrim.cmm compiler/cbits/genSym.c compiler/cbits/cutils.c hs-source-dirs: @@ -128,16 +129,12 @@ ghc-lib/stage0/compiler/build libraries/template-haskell libraries/ghc-boot-th - compiler/basicTypes - compiler/profiling - compiler/simplCore compiler/typecheck libraries/ghc-boot libraries/ghc-heap compiler/prelude compiler/parser compiler/iface - compiler/types compiler/utils libraries/ghci compiler/main @@ -147,47 +144,31 @@ Lexer Parser exposed-modules: - Annotations ApiAnnotation - Avail Bag - BasicTypes BinFingerprint Binary BooleanFormula BufWrite - Class CliOption - CoAxiom - Coercion - ConLike Config Constants Constraint - CoreMonad - CostCentre - CostCentreState - Cpr Ctype - DataCon - Demand Digraph Encoding EnumSet ErrUtils Exception FV - FamInstEnv FastFunctions FastMutInt FastString FastStringEnv - FieldLabel FileCleanup FileSettings Fingerprint FiniteMap - ForeignCall GHC.BaseDir GHC.ByteCode.Types GHC.Cmm @@ -204,21 +185,43 @@ GHC.Cmm.Type GHC.Core GHC.Core.Arity + GHC.Core.Class + GHC.Core.Coercion + GHC.Core.Coercion.Axiom + GHC.Core.Coercion.Opt + GHC.Core.ConLike + GHC.Core.DataCon GHC.Core.FVs + GHC.Core.FamInstEnv + GHC.Core.InstEnv GHC.Core.Make GHC.Core.Map + GHC.Core.Op.ConstantFold + GHC.Core.Op.Monad + GHC.Core.Op.OccurAnal GHC.Core.Op.Tidy + GHC.Core.PatSyn GHC.Core.Ppr + GHC.Core.Predicate GHC.Core.Rules GHC.Core.Seq GHC.Core.SimpleOpt GHC.Core.Stats GHC.Core.Subst + GHC.Core.TyCo.FVs + GHC.Core.TyCo.Ppr + GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst + GHC.Core.TyCo.Tidy + GHC.Core.TyCon + GHC.Core.Type GHC.Core.Unfold + GHC.Core.Unify GHC.Core.Utils GHC.CoreToIface GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine + GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Monad GHC.Driver.Packages @@ -227,6 +230,7 @@ GHC.Driver.Plugins GHC.Driver.Session GHC.Driver.Types + GHC.Driver.Ways GHC.Exts.Heap GHC.Exts.Heap.ClosureTypes GHC.Exts.Heap.Closures @@ -275,8 +279,39 @@ GHC.Runtime.Linker.Types GHC.Serialized GHC.Stg.Syntax + GHC.Types.Annotations + GHC.Types.Avail + GHC.Types.Basic + GHC.Types.CostCentre + GHC.Types.CostCentre.State + GHC.Types.Cpr + GHC.Types.Demand + GHC.Types.FieldLabel + GHC.Types.ForeignCall + GHC.Types.Id + GHC.Types.Id.Info + GHC.Types.Id.Make + GHC.Types.Literal + GHC.Types.Module + GHC.Types.Name + GHC.Types.Name.Cache + GHC.Types.Name.Env + GHC.Types.Name.Occurrence + GHC.Types.Name.Reader + GHC.Types.Name.Set GHC.Types.RepType + GHC.Types.SrcLoc + GHC.Types.Unique + GHC.Types.Unique.DFM + GHC.Types.Unique.DSet + GHC.Types.Unique.FM + GHC.Types.Unique.Set + GHC.Types.Unique.Supply + GHC.Types.Var + GHC.Types.Var.Env + GHC.Types.Var.Set GHC.UniqueSubdir + GHC.Utils.Lexeme GHC.Version GHCi.BreakArray GHCi.FFI @@ -288,9 +323,6 @@ HaddockUtils HeaderInfo IOEnv - Id - IdInfo - InstEnv Json KnownUniques Language.Haskell.TH @@ -301,40 +333,24 @@ Language.Haskell.TH.Ppr Language.Haskell.TH.PprLib Language.Haskell.TH.Syntax - Lexeme Lexer ListSetOps - Literal Maybes - MkId - Module MonadUtils - Name - NameCache - NameEnv - NameSet - OccName - OccurAnal - OptCoercion OrdList Outputable Pair Panic Parser - PatSyn PlainPanic PlatformConstants PprColour - Predicate PrelNames - PrelRules Pretty PrimOp RdrHsSyn - RdrName Settings SizedSeq - SrcLoc Stream StringBuffer SysTools.BaseDir @@ -346,24 +362,7 @@ TcType ToolSettings TrieMap - TyCoFVs - TyCoPpr - TyCoRep - TyCoSubst - TyCoTidy - TyCon - Type TysPrim TysWiredIn - Unify - UniqDFM - UniqDSet - UniqFM - UniqSet - UniqSupply - Unique UnitInfo Util - Var - VarEnv - VarSet diff --git a/ghc-lib/stage0/compiler/build/Config.hs b/ghc-lib/stage0/compiler/build/Config.hs --- a/ghc-lib/stage0/compiler/build/Config.hs +++ b/ghc-lib/stage0/compiler/build/Config.hs @@ -22,7 +22,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String -cBooterVersion = "8.6.5" +cBooterVersion = "8.8.3" cStage :: String cStage = show (1 :: Int) diff --git a/ghc-lib/stage0/compiler/build/Lexer.hs b/ghc-lib/stage0/compiler/build/Lexer.hs --- a/ghc-lib/stage0/compiler/build/Lexer.hs +++ b/ghc-lib/stage0/compiler/build/Lexer.hs @@ -58,7 +58,7 @@ import Outputable import StringBuffer import FastString -import UniqFM +import GHC.Types.Unique.FM import Util ( readRational, readHexRational ) -- compiler/main @@ -66,11 +66,11 @@ import GHC.Driver.Session as DynFlags -- compiler/basicTypes -import SrcLoc -import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), - IntegralLit(..), FractionalLit(..), - SourceText(..) ) +import GHC.Types.SrcLoc +import GHC.Types.Module +import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..), + IntegralLit(..), FractionalLit(..), + SourceText(..) ) -- compiler/parser import Ctype @@ -84,11 +84,11 @@ #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array -import Data.Array.Base (unsafeAt) #else import Array #endif #if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) import GHC.Exts #else import GlaExts diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs --- a/ghc-lib/stage0/compiler/build/Parser.hs +++ b/ghc-lib/stage0/compiler/build/Parser.hs @@ -43,8 +43,8 @@ import GHC.Hs -- compiler/main -import GHC.Driver.Phases ( HscSource(..) ) -import GHC.Driver.Types ( IsBootInterface, WarningTxt(..) ) +import GHC.Driver.Phases ( HscSource(..) ) +import GHC.Driver.Types ( IsBootInterface, WarningTxt(..) ) import GHC.Driver.Session import GHC.Driver.Backpack.Syntax import UnitInfo @@ -57,16 +57,16 @@ import Outputable -- compiler/basicTypes -import RdrName -import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) -import DataCon ( DataCon, dataConName ) -import SrcLoc -import Module -import BasicTypes +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) +import GHC.Core.DataCon ( DataCon, dataConName ) +import GHC.Types.SrcLoc +import GHC.Types.Module +import GHC.Types.Basic -- compiler/types -import Type ( funTyCon ) -import Class ( FunDep ) +import GHC.Core.Type ( funTyCon ) +import GHC.Core.Class ( FunDep ) -- compiler/parser import RdrHsSyn @@ -78,7 +78,7 @@ import TcEvidence ( emptyTcEvBinds ) -- compiler/prelude -import ForeignCall +import GHC.Types.ForeignCall import TysPrim ( eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, diff --git a/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs b/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs --- a/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs +++ b/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs @@ -111,7 +111,6 @@ rESERVED_STACK_WORDS, aP_STACK_SPLIM, wORD_SIZE, - dOUBLE_SIZE, cINT_SIZE, cLONG_SIZE, cLONG_LONG_SIZE, diff --git a/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs b/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs --- a/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs +++ b/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs @@ -118,7 +118,6 @@ pc_RESERVED_STACK_WORDS :: Int, pc_AP_STACK_SPLIM :: Int, pc_WORD_SIZE :: Int, - pc_DOUBLE_SIZE :: Int, pc_CINT_SIZE :: Int, pc_CLONG_SIZE :: Int, pc_CLONG_LONG_SIZE :: Int, diff --git a/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs b/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs --- a/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs +++ b/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs @@ -224,8 +224,6 @@ aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags) wORD_SIZE :: DynFlags -> Int wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) -dOUBLE_SIZE :: DynFlags -> Int -dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (platformConstants dflags) cINT_SIZE :: DynFlags -> Int cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags) cLONG_SIZE :: DynFlags -> Int diff --git a/ghc-lib/stage0/lib/ghcversion.h b/ghc-lib/stage0/lib/ghcversion.h --- a/ghc-lib/stage0/lib/ghcversion.h +++ b/ghc-lib/stage0/lib/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200229 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200331 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/lib/platformConstants b/ghc-lib/stage0/lib/platformConstants --- a/ghc-lib/stage0/lib/platformConstants +++ b/ghc-lib/stage0/lib/platformConstants @@ -118,7 +118,6 @@ pc_RESERVED_STACK_WORDS = 21, pc_AP_STACK_SPLIM = 1024, pc_WORD_SIZE = 8, - pc_DOUBLE_SIZE = 8, pc_CINT_SIZE = 4, pc_CLONG_SIZE = 8, pc_CLONG_LONG_SIZE = 8, diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "04d30137771a6cf8a18fda1ced25f78d0b2eb204" +cProjectGitCommitId = "4b9c586472bf99425f7bbcf346472d7c54f05028" cProjectVersion :: String -cProjectVersion = "8.11.0.20200229" +cProjectVersion = "8.11.0.20200331" cProjectVersionInt :: String cProjectVersionInt = "811" cProjectPatchLevel :: String -cProjectPatchLevel = "020200229" +cProjectPatchLevel = "020200331" cProjectPatchLevel1 :: String cProjectPatchLevel1 = "0" cProjectPatchLevel2 :: String -cProjectPatchLevel2 = "20200229" +cProjectPatchLevel2 = "20200331" diff --git a/includes/MachDeps.h b/includes/MachDeps.h --- a/includes/MachDeps.h +++ b/includes/MachDeps.h @@ -32,9 +32,7 @@ * * To get target's values it is preferred to use runtime target * configuration from 'targetPlatform :: DynFlags -> Platform' - * record. A few wrappers are already defined and used throughout GHC: - * wORD_SIZE :: DynFlags -> Int - * wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) + * record. * * Hence we hide these macros from GHC_STAGE=1 */ diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -21,7 +21,8 @@ -- here as this would require adding transitive dependencies to the -- @template-haskell@ package, which must have a minimal dependency set. data Extension --- See Note [Updating flag description in the User's Guide] in DynFlags +-- See Note [Updating flag description in the User's Guide] in +-- GHC.Driver.Session = Cpp | OverlappingInstances | UndecidableInstances diff --git a/libraries/ghc-boot/GHC/Platform.hs b/libraries/ghc-boot/GHC/Platform.hs --- a/libraries/ghc-boot/GHC/Platform.hs +++ b/libraries/ghc-boot/GHC/Platform.hs @@ -21,6 +21,11 @@ platformUsesFrameworks, platformWordSizeInBytes, platformWordSizeInBits, + platformMinInt, + platformMaxInt, + platformMaxWord, + platformInIntRange, + platformInWordRange, PlatformMisc(..), IntegerLibrary(..), @@ -33,6 +38,8 @@ import Prelude -- See Note [Why do we import Prelude here?] import GHC.Read +import Data.Word +import Data.Int -- | Contains the bare-bones arch and os information. This isn't enough for -- code gen, but useful for tasks where we can fall back upon the host @@ -305,3 +312,29 @@ = IntegerGMP | IntegerSimple deriving (Read, Show, Eq) + +-- | Minimum representable Int value for the given platform +platformMinInt :: Platform -> Integer +platformMinInt p = case platformWordSize p of + PW4 -> toInteger (minBound :: Int32) + PW8 -> toInteger (minBound :: Int64) + +-- | Maximum representable Int value for the given platform +platformMaxInt :: Platform -> Integer +platformMaxInt p = case platformWordSize p of + PW4 -> toInteger (maxBound :: Int32) + PW8 -> toInteger (maxBound :: Int64) + +-- | Maximum representable Word value for the given platform +platformMaxWord :: Platform -> Integer +platformMaxWord p = case platformWordSize p of + PW4 -> toInteger (maxBound :: Word32) + PW8 -> toInteger (maxBound :: Word64) + +-- | Test if the given Integer is representable with a platform Int +platformInIntRange :: Platform -> Integer -> Bool +platformInIntRange platform x = x >= platformMinInt platform && x <= platformMaxInt platform + +-- | Test if the given Integer is representable with a platform Word +platformInWordRange :: Platform -> Integer -> Bool +platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -50,13 +50,10 @@ ------------------------------------------------------------------------ -- Boxes -aToWord# :: Any -> Word# -aToWord# _ = 0## - - -reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int# -reallyUnsafePtrEqualityUpToTag# _ _ = 0# +foreign import prim "aToWordzh" aToWord# :: Any -> Word# +foreign import prim "reallyUnsafePtrEqualityUpToTag" + reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int# -- | An arbitrary Haskell value in a safe Box. The point is that even -- unevaluated thunks can safely be moved around inside the Box, and when @@ -350,7 +347,8 @@ allClosures _ = [] #if __GLASGOW_HASKELL__ >= 809 --- | Get the size of a closure in words. +-- | Get the size of the top-level closure in words. +-- Includes header and payload. Does not follow pointers. -- -- @since 8.10.1 closureSize :: Box -> Int diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc --- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc @@ -31,10 +31,10 @@ -- -- for more details on this data structure. data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode + entry :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE ptrs :: HalfWord, nptrs :: HalfWord, tipe :: ClosureType, srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode + code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE } deriving (Show, Generic) diff --git a/libraries/ghc-heap/cbits/HeapPrim.cmm b/libraries/ghc-heap/cbits/HeapPrim.cmm new file mode 100644 --- /dev/null +++ b/libraries/ghc-heap/cbits/HeapPrim.cmm @@ -0,0 +1,13 @@ +#include "Cmm.h" + +aToWordzh (P_ clos) +{ + return (clos); +} + +reallyUnsafePtrEqualityUpToTag (W_ clos1, W_ clos2) +{ + clos1 = UNTAG(clos1); + clos2 = UNTAG(clos2); + return (clos1 == clos2); +} diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -104,7 +104,8 @@ -- | Create an info table for a constructor MkConInfoTable - :: Int -- ptr words + :: Bool -- TABLES_NEXT_TO_CODE + -> Int -- ptr words -> Int -- non-ptr words -> Int -- constr tag -> Int -- pointer tag @@ -215,8 +216,13 @@ -- | Evaluate something. This is used to support :force in GHCi. Seq :: HValueRef - -> Message (EvalResult ()) + -> Message (EvalStatus ()) + -- | Resume forcing a free variable in a breakpoint (#2950) + ResumeSeq + :: RemoteRef (ResumeContext ()) + -> Message (EvalStatus ()) + deriving instance Show (Message a) @@ -472,7 +478,7 @@ 15 -> Msg <$> MallocStrings <$> get 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get) 17 -> Msg <$> FreeFFI <$> get - 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get) + 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get) 19 -> Msg <$> (EvalStmt <$> get <*> get) 20 -> Msg <$> (ResumeStmt <$> get <*> get) 21 -> Msg <$> (AbandonStmt <$> get) @@ -492,6 +498,7 @@ 35 -> Msg <$> (GetClosure <$> get) 36 -> Msg <$> (Seq <$> get) 37 -> Msg <$> return RtsRevertCAFs + 38 -> Msg <$> (ResumeSeq <$> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -514,7 +521,7 @@ MallocStrings bss -> putWord8 15 >> put bss PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res FreeFFI p -> putWord8 17 >> put p - MkConInfoTable p n t pt d -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d + MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d EvalStmt opts val -> putWord8 19 >> put opts >> put val ResumeStmt opts val -> putWord8 20 >> put opts >> put val AbandonStmt val -> putWord8 21 >> put val @@ -534,6 +541,7 @@ GetClosure a -> putWord8 35 >> put a Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 + ResumeSeq a -> putWord8 38 >> put a -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -52,15 +52,13 @@ import Prelude import Foreign.ForeignPtr -import qualified Control.Monad.Fail as Fail - ----------------------------------------------------- -- -- The Quasi class -- ----------------------------------------------------- -class (MonadIO m, Fail.MonadFail m) => Quasi m where +class (MonadIO m, MonadFail m) => Quasi m where qNewName :: String -> m Name -- ^ Fresh names @@ -187,12 +185,9 @@ instance Monad Q where Q m >>= k = Q (m >>= \x -> unQ (k x)) (>>) = (*>) -#if !MIN_VERSION_base(4,13,0) - fail = Fail.fail -#endif -instance Fail.MonadFail Q where - fail s = report True s >> Q (Fail.fail "Q monad failure") +instance MonadFail Q where + fail s = report True s >> Q (fail "Q monad failure") instance Functor Q where fmap f (Q x) = Q (fmap f x)