diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -124,7 +124,7 @@ import Outputable import FastString import DynFlags -import Platform +import GHC.Platform import UniqSet import Util import PprCore ( {- instances -} ) @@ -579,8 +579,7 @@ -> FunctionOrData -> CLabel -mkForeignLabel str mb_sz src fod - = ForeignLabel str mb_sz src fod +mkForeignLabel = ForeignLabel -- | Update the label size field in a ForeignLabel diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -16,7 +16,7 @@ import Hoopl.Collections import Hoopl.Dataflow import Module -import Platform +import GHC.Platform import Digraph import CLabel import PprCmmDecl () diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -13,7 +13,7 @@ import PprCmm () import DynFlags -import Platform +import GHC.Platform import Outputable -- Calculate the 'GlobalReg' or stack locations for function call @@ -64,13 +64,20 @@ assign_regs assts (r:rs) regs | isVecType ty = vec | isFloatType ty = float | otherwise = int - where vec = case (w, regs) of - (W128, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) - (W256, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) - (W512, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) + where vec = case regs of + (vs, fs, ds, ls, s:ss) + | passVectorInReg w dflags + -> let elt_ty = vecElemType ty + reg_ty = if isFloatType elt_ty + then Float else Integer + reg_class = case w of + W128 -> XmmReg + W256 -> YmmReg + W512 -> ZmmReg + _ -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width" + in k (RegisterParam + (reg_class s (vecLength ty) (typeWidth elt_ty) reg_ty), + (vs, fs, ds, ls, ss)) _ -> (assts, (r:rs)) float = case (w, regs) of (W32, (vs, fs, ds, ls, s:ss)) @@ -89,6 +96,7 @@ (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) -> k (RegisterParam l, (vs, fs, ds, ls, ss)) _ -> (assts, (r:rs)) + k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty @@ -202,11 +210,13 @@ -- only use this functionality in hand-written C-- code in the RTS. realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover dflags - | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ - realLongRegs dflags ++ - map XmmReg (realXmmRegNos dflags) - | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ - realFloatRegs dflags ++ - realDoubleRegs dflags ++ - realLongRegs dflags ++ - map XmmReg (realXmmRegNos dflags) + | passFloatArgsInXmm dflags + = map ($VGcPtr) (realVanillaRegs dflags) ++ + realLongRegs dflags ++ + map (\x -> XmmReg x 2 W64 Integer) (realXmmRegNos dflags) + | otherwise + = map ($VGcPtr) (realVanillaRegs dflags) ++ + realFloatRegs dflags ++ + realDoubleRegs dflags ++ + realLongRegs dflags ++ + map (\x -> XmmReg x 2 W64 Integer) (realXmmRegNos dflags) diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -14,6 +14,7 @@ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg , VGcPtr(..) + , GlobalVecRegTy(..) , DefinerOfRegs, UserOfRegs , foldRegsDefd, foldRegsUsed @@ -41,6 +42,7 @@ import Unique import Data.Set (Set) +import Data.Monoid ((<>)) import qualified Data.Set as Set import BasicTypes (Alignment, mkAlignment, alignmentOf) @@ -392,6 +394,7 @@ ----------------------------------------------------------------------------- {- Note [Overlapping global registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The backend might not faithfully implement the abstraction of the STG machine with independent registers for different values of type @@ -413,6 +416,26 @@ equality of STG registers and does not take overlap into account. However it is still used in UserOfRegs/DefinerOfRegs and there are likely still bugs there, beware! + + +Note [SIMD registers] +~~~~~~~~~~~~~~~~~~~~~ + +GHC's treatment of SIMD registers is heavily modelled after the x86_64 +architecture. Namely we have 128- (XMM), 256- (YMM), and 512-bit (ZMM) +registers. Furthermore, we treat each possible format in these registers as a +distinct register which overlaps with the others. For instance, we XMM1 as a +2xI64 register is distinct from but overlaps with (in the sense defined in Note +[Overlapping global registers]) its use as a 4xI32 register. + +This model makes it easier to fit SIMD registers into the NCG, which generally +expects that each global register has a single, known CmmType. + +In the future we could consider further refactoring this to eliminate the +XMM, YMM, and ZMM register names (which are quite x86-specific) and instead just +having a set of NxM-bit vector registers (e.g. Vec2x64A, Vec2x64B, ..., +Vec4x32A, ..., Vec4x64A). + -} data GlobalReg @@ -432,12 +455,15 @@ | XmmReg -- 128-bit SIMD vector register {-# UNPACK #-} !Int -- its number + !Length !Width !GlobalVecRegTy | YmmReg -- 256-bit SIMD vector register {-# UNPACK #-} !Int -- its number + !Length !Width !GlobalVecRegTy | ZmmReg -- 512-bit SIMD vector register {-# UNPACK #-} !Int -- its number + !Length !Width !GlobalVecRegTy -- STG registers | Sp -- Stack ptr; points to last occupied stack location. @@ -478,17 +504,17 @@ deriving( Show ) +data GlobalVecRegTy = Integer | Float + deriving (Show, Eq, Ord) + instance Eq GlobalReg where VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes FloatReg i == FloatReg j = i==j DoubleReg i == DoubleReg j = i==j LongReg i == LongReg j = i==j - -- NOTE: XMM, YMM, ZMM registers actually are the same registers - -- at least with respect to store at YMM i and then read from XMM i - -- and similarly for ZMM etc. - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j + XmmReg i l w grt == XmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt' + YmmReg i l w grt == YmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt' + ZmmReg i l w grt == ZmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt' Sp == Sp = True SpLim == SpLim = True Hp == Hp = True @@ -512,9 +538,21 @@ compare (FloatReg i) (FloatReg j) = compare i j compare (DoubleReg i) (DoubleReg j) = compare i j compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j + compare (XmmReg i l w grt) + (XmmReg j l' w' grt') = compare i j + <> compare l l' + <> compare w w' + <> compare grt grt' + compare (YmmReg i l w grt) + (YmmReg j l' w' grt') = compare i j + <> compare l l' + <> compare w w' + <> compare grt grt' + compare (ZmmReg i l w grt) + (ZmmReg j l' w' grt') = compare i j + <> compare l l' + <> compare w w' + <> compare grt grt' compare Sp Sp = EQ compare SpLim SpLim = EQ compare Hp Hp = EQ @@ -538,12 +576,12 @@ compare _ (DoubleReg _) = GT compare (LongReg _) _ = LT compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT + compare (XmmReg _ _ _ _) _ = LT + compare _ (XmmReg _ _ _ _) = GT + compare (YmmReg _ _ _ _) _ = LT + compare _ (YmmReg _ _ _ _) = GT + compare (ZmmReg _ _ _ _) _ = LT + compare _ (ZmmReg _ _ _ _) = GT compare Sp _ = LT compare _ Sp = GT compare SpLim _ = LT @@ -596,12 +634,15 @@ 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 StgCmmPrim -globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32) -globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32) -globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) +globalRegType _ (XmmReg _ l w ty) = case ty of + Integer -> cmmVec l (cmmBits w) + Float -> cmmVec l (cmmFloat w) +globalRegType _ (YmmReg _ l w ty) = case ty of + Integer -> cmmVec l (cmmBits w) + Float -> cmmVec l (cmmFloat w) +globalRegType _ (ZmmReg _ l w ty) = case ty of + Integer -> cmmVec l (cmmBits w) + Float -> cmmVec l (cmmFloat w) globalRegType dflags Hp = gcWord dflags -- The initialiser for all diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -45,7 +45,7 @@ import qualified Stream import Hoopl.Collections -import Platform +import GHC.Platform import Maybes import DynFlags import Panic diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -5,6 +5,7 @@ -- CmmLint: checking the correctness of Cmm statements and expressions -- ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} module CmmLint ( cmmLint, cmmLintGraph @@ -24,7 +25,7 @@ import Outputable import DynFlags -import Control.Monad (liftM, ap) +import Control.Monad (ap) -- Things to check: -- - invariant on CmmBlock in CmmExpr (see comment there) @@ -147,9 +148,13 @@ dflags <- getDynFlags erep <- lintCmmExpr expr let reg_ty = cmmRegType dflags reg - if (erep `cmmEqType_ignoring_ptrhood` reg_ty) - then return () - else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + case isVecCatType reg_ty of + True -> if ((typeWidth reg_ty) == (typeWidth erep)) + then return () + else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + _ -> if (erep `cmmEqType_ignoring_ptrhood` reg_ty) + then return () + else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty CmmStore l r -> do _ <- lintCmmExpr l @@ -212,9 +217,7 @@ -- just a basic error monad: newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } - -instance Functor CmmLint where - fmap = liftM + deriving (Functor) instance Applicative CmmLint where pure a = CmmLint (\_ -> Right a) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -136,8 +136,9 @@ | MO_VU_Rem Length Width -- Floting point vector element insertion and extraction operations - | MO_VF_Insert Length Width -- Insert scalar into vector - | MO_VF_Extract Length Width -- Extract scalar from vector + | MO_VF_Broadcast Length Width -- Broadcast a scalar into a vector + | MO_VF_Insert Length Width -- Insert scalar into vector + | MO_VF_Extract Length Width -- Extract scalar from vector -- Floating point vector operations | MO_VF_Add Length Width @@ -430,6 +431,7 @@ MO_VU_Quot l w -> cmmVec l (cmmBits w) MO_VU_Rem l w -> cmmVec l (cmmBits w) + MO_VF_Broadcast l w -> cmmVec l (cmmFloat w) MO_VF_Insert l w -> cmmVec l (cmmFloat w) MO_VF_Extract _ w -> cmmFloat w @@ -522,16 +524,21 @@ 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] + -- offset is always W32 as mentioned in StgCmmPrim.hs + MO_VF_Broadcast l r -> [vecwidth l r, r] + MO_VF_Insert l r -> [vecwidth l r, r, W32] + MO_VF_Extract l r -> [vecwidth l r, W32] - MO_VF_Add _ r -> [r,r] - MO_VF_Sub _ r -> [r,r] - MO_VF_Mul _ r -> [r,r] - MO_VF_Quot _ r -> [r,r] - MO_VF_Neg _ r -> [r] + -- NOTE: The below is owing to the fact that floats use the SSE registers + MO_VF_Add l w -> [vecwidth l w, vecwidth l w] + MO_VF_Sub l w -> [vecwidth l w, vecwidth l w] + MO_VF_Mul l w -> [vecwidth l w, vecwidth l w] + MO_VF_Quot l w -> [vecwidth l w, vecwidth l w] + MO_VF_Neg l w -> [vecwidth l w] MO_AlignmentCheck _ r -> [r] + where + vecwidth l w = widthFromBytes (l*widthInBytes w) ----------------------------------------------------------------------------- -- CallishMachOp @@ -556,7 +563,9 @@ | MO_F64_Acosh | MO_F64_Atanh | MO_F64_Log + | MO_F64_Log1P | MO_F64_Exp + | MO_F64_ExpM1 | MO_F64_Fabs | MO_F64_Sqrt | MO_F32_Pwr @@ -573,7 +582,9 @@ | MO_F32_Acosh | MO_F32_Atanh | MO_F32_Log + | MO_F32_Log1P | MO_F32_Exp + | MO_F32_ExpM1 | MO_F32_Fabs | MO_F32_Sqrt @@ -589,6 +600,7 @@ | MO_SubIntC Width | MO_U_Mul2 Width + | MO_ReadBarrier | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -114,7 +114,7 @@ cml_cont :: Maybe Label, -- Label of continuation (Nothing for return or tail call) -- - -- Note [Continuation BlockId]: these BlockIds are called + -- Note [Continuation BlockIds]: these BlockIds are called -- Continuation BlockIds, and are the only BlockIds that can -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or -- (CmmStackSlot (Young b) _). diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -25,7 +25,7 @@ import Util import Outputable -import Platform +import GHC.Platform import Data.Bits import Data.Maybe diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -198,6 +198,8 @@ ----------------------------------------------------------------------------- -} { +{-# LANGUAGE TupleSections #-} + module CmmParse ( parseCmmFile ) where import GhcPrelude @@ -235,7 +237,7 @@ import CostCentre import ForeignCall import Module -import Platform +import GHC.Platform import Literal import Unique import UniqFM @@ -808,7 +810,7 @@ | foreign_formal ',' foreign_formals { $1 : $3 } foreign_formal :: { CmmParse (LocalReg, ForeignHint) } - : local_lreg { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) } + : local_lreg { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) } | STRING local_lreg {% do h <- parseCmmHint $1; return $ do e <- $2; return (e,h) } @@ -999,36 +1001,37 @@ callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ - ( "write_barrier", (,) MO_WriteBarrier ), + ( "read_barrier", (MO_ReadBarrier,)), + ( "write_barrier", (MO_WriteBarrier,)), ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), ( "memset", memcpyLikeTweakArgs MO_Memset ), ( "memmove", memcpyLikeTweakArgs MO_Memmove ), ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), - ("prefetch0", (,) $ MO_Prefetch_Data 0), - ("prefetch1", (,) $ MO_Prefetch_Data 1), - ("prefetch2", (,) $ MO_Prefetch_Data 2), - ("prefetch3", (,) $ MO_Prefetch_Data 3), + ("prefetch0", (MO_Prefetch_Data 0,)), + ("prefetch1", (MO_Prefetch_Data 1,)), + ("prefetch2", (MO_Prefetch_Data 2,)), + ("prefetch3", (MO_Prefetch_Data 3,)), - ( "popcnt8", (,) $ MO_PopCnt W8 ), - ( "popcnt16", (,) $ MO_PopCnt W16 ), - ( "popcnt32", (,) $ MO_PopCnt W32 ), - ( "popcnt64", (,) $ MO_PopCnt W64 ), + ( "popcnt8", (MO_PopCnt W8,)), + ( "popcnt16", (MO_PopCnt W16,)), + ( "popcnt32", (MO_PopCnt W32,)), + ( "popcnt64", (MO_PopCnt W64,)), - ( "pdep8", (,) $ MO_Pdep W8 ), - ( "pdep16", (,) $ MO_Pdep W16 ), - ( "pdep32", (,) $ MO_Pdep W32 ), - ( "pdep64", (,) $ MO_Pdep W64 ), + ( "pdep8", (MO_Pdep W8,)), + ( "pdep16", (MO_Pdep W16,)), + ( "pdep32", (MO_Pdep W32,)), + ( "pdep64", (MO_Pdep W64,)), - ( "pext8", (,) $ MO_Pext W8 ), - ( "pext16", (,) $ MO_Pext W16 ), - ( "pext32", (,) $ MO_Pext W32 ), - ( "pext64", (,) $ MO_Pext W64 ), + ( "pext8", (MO_Pext W8,)), + ( "pext16", (MO_Pext W16,)), + ( "pext32", (MO_Pext W32,)), + ( "pext64", (MO_Pext W64,)), - ( "cmpxchg8", (,) $ MO_Cmpxchg W8 ), - ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ), - ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ), - ( "cmpxchg64", (,) $ MO_Cmpxchg W64 ) + ( "cmpxchg8", (MO_Cmpxchg W8,)), + ( "cmpxchg16", (MO_Cmpxchg W16,)), + ( "cmpxchg32", (MO_Cmpxchg W32,)), + ( "cmpxchg64", (MO_Cmpxchg W64,)) -- ToDo: the rest, maybe -- edit: which rest? diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -26,7 +26,7 @@ import HscTypes import Control.Monad import Outputable -import Platform +import GHC.Platform ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -23,7 +23,7 @@ import Maybes import Control.Monad import Outputable -import Platform +import GHC.Platform import UniqSupply import Hoopl.Block import Hoopl.Collections diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -14,7 +14,7 @@ import Hoopl.Collections import Hoopl.Graph import CodeGen.Platform -import Platform (isARM, platformArch) +import GHC.Platform (isARM, platformArch) import DynFlags import Unique diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs --- a/compiler/cmm/Hoopl/Block.hs +++ b/compiler/cmm/Hoopl/Block.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} module Hoopl.Block ( C , O @@ -64,14 +66,8 @@ JustC :: t -> MaybeC C t NothingC :: MaybeC O t - -instance Functor (MaybeO ex) where - fmap _ NothingO = NothingO - fmap f (JustO a) = JustO (f a) - -instance Functor (MaybeC ex) where - fmap _ NothingC = NothingC - fmap f (JustC a) = JustC (f a) +deriving instance Functor (MaybeO ex) +deriving instance Functor (MaybeC ex) -- ----------------------------------------------------------------------------- -- The Block type diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -335,8 +335,8 @@ local = CmmLocal reg width = cmmRegWidth dflags local expr = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot] - in CmmAssign local expr - + in CmmAssign local expr + | otherwise = CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) where ty = localRegType reg diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GADTs #-} +{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-} ----------------------------------------------------------------------------- -- @@ -44,7 +44,7 @@ import DynFlags import FastString import Outputable -import Platform +import GHC.Platform import UniqSet import UniqFM import Unique @@ -61,7 +61,7 @@ import Data.Word import System.IO import qualified Data.Map as Map -import Control.Monad (liftM, ap) +import Control.Monad (ap) import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST @@ -713,6 +713,10 @@ (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" ++ " should have been handled earlier!") + MO_VF_Broadcast {} -> pprTrace "offending mop:" + (text "MO_VF_Broadcast") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Broadcast" + ++ " should have been handled earlier!") MO_VF_Insert {} -> pprTrace "offending mop:" (text "MO_VF_Insert") (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" @@ -788,7 +792,9 @@ MO_F64_Acosh -> text "acosh" MO_F64_Atan -> text "atan" MO_F64_Log -> text "log" + MO_F64_Log1P -> text "log1p" MO_F64_Exp -> text "exp" + MO_F64_ExpM1 -> text "expm1" MO_F64_Sqrt -> text "sqrt" MO_F64_Fabs -> text "fabs" MO_F32_Pwr -> text "powf" @@ -805,9 +811,12 @@ MO_F32_Acosh -> text "acoshf" MO_F32_Atanh -> text "atanhf" MO_F32_Log -> text "logf" + MO_F32_Log1P -> text "log1pf" MO_F32_Exp -> text "expf" + MO_F32_ExpM1 -> text "expm1f" MO_F32_Sqrt -> text "sqrtf" MO_F32_Fabs -> text "fabsf" + MO_ReadBarrier -> text "load_load_barrier" MO_WriteBarrier -> text "write_barrier" MO_Memcpy _ -> text "memcpy" MO_Memset _ -> text "memset" @@ -1078,10 +1087,7 @@ <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) -newtype TE a = TE { unTE :: TEState -> (a, TEState) } - -instance Functor TE where - fmap = liftM +newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor) instance Applicative TE where pure a = TE $ \s -> (a, s) diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -261,9 +261,9 @@ FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n - XmmReg n -> text "XMM" <> int n - YmmReg n -> text "YMM" <> int n - ZmmReg n -> text "ZMM" <> int n + XmmReg n _ _ _ -> text "XMM" <> int n + YmmReg n _ _ _ -> text "YMM" <> int n + ZmmReg n _ _ _ -> text "ZMM" <> int n Sp -> text "Sp" SpLim -> text "SpLim" Hp -> text "Hp" diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs --- a/compiler/cmm/SMRep.hs +++ b/compiler/cmm/SMRep.hs @@ -49,7 +49,7 @@ import BasicTypes( ConTagZ ) import DynFlags import Outputable -import Platform +import GHC.Platform import FastString import Data.Word diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -57,27 +57,27 @@ baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") -baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags -baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags -baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags -baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags -baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags -baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags -baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") -baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags -baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags -baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags -baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags -baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags -baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags -baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") -baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags -baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags -baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags -baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags -baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags -baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags -baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") +baseRegOffset dflags (XmmReg 1 _ _ _) = oFFSET_StgRegTable_rXMM1 dflags +baseRegOffset dflags (XmmReg 2 _ _ _) = oFFSET_StgRegTable_rXMM2 dflags +baseRegOffset dflags (XmmReg 3 _ _ _) = oFFSET_StgRegTable_rXMM3 dflags +baseRegOffset dflags (XmmReg 4 _ _ _) = oFFSET_StgRegTable_rXMM4 dflags +baseRegOffset dflags (XmmReg 5 _ _ _) = oFFSET_StgRegTable_rXMM5 dflags +baseRegOffset dflags (XmmReg 6 _ _ _) = oFFSET_StgRegTable_rXMM6 dflags +baseRegOffset _ (XmmReg n _ _ _) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") +baseRegOffset dflags (YmmReg 1 _ _ _) = oFFSET_StgRegTable_rYMM1 dflags +baseRegOffset dflags (YmmReg 2 _ _ _) = oFFSET_StgRegTable_rYMM2 dflags +baseRegOffset dflags (YmmReg 3 _ _ _) = oFFSET_StgRegTable_rYMM3 dflags +baseRegOffset dflags (YmmReg 4 _ _ _) = oFFSET_StgRegTable_rYMM4 dflags +baseRegOffset dflags (YmmReg 5 _ _ _) = oFFSET_StgRegTable_rYMM5 dflags +baseRegOffset dflags (YmmReg 6 _ _ _) = oFFSET_StgRegTable_rYMM6 dflags +baseRegOffset _ (YmmReg n _ _ _) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") +baseRegOffset dflags (ZmmReg 1 _ _ _) = oFFSET_StgRegTable_rZMM1 dflags +baseRegOffset dflags (ZmmReg 2 _ _ _) = oFFSET_StgRegTable_rZMM2 dflags +baseRegOffset dflags (ZmmReg 3 _ _ _) = oFFSET_StgRegTable_rZMM3 dflags +baseRegOffset dflags (ZmmReg 4 _ _ _) = oFFSET_StgRegTable_rZMM4 dflags +baseRegOffset dflags (ZmmReg 5 _ _ _) = oFFSET_StgRegTable_rZMM5 dflags +baseRegOffset dflags (ZmmReg 6 _ _ _) = oFFSET_StgRegTable_rZMM6 dflags +baseRegOffset _ (ZmmReg n _ _ _) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs --- a/compiler/codeGen/CodeGen/Platform.hs +++ b/compiler/codeGen/CodeGen/Platform.hs @@ -6,7 +6,7 @@ import GhcPrelude import CmmExpr -import Platform +import GHC.Platform import Reg import qualified CodeGen.Platform.ARM as ARM diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -632,6 +632,7 @@ when eager_blackholing $ do emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr + -- See Note [Heap memory barriers] in SMP.h. emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -664,7 +665,7 @@ ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: - { upd_closure <- link_caf node True + { upd_closure <- link_caf node ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } else do {tickyUpdateFrameOmitted; body} } @@ -704,11 +705,10 @@ -- See Note [CAF management] in rts/sm/Storage.c link_caf :: LocalReg -- pointer to the closure - -> Bool -- True <=> updatable, False <=> single-entry -> FCode CmmExpr -- Returns amode for closure to be updated -- This function returns the address of the black hole, so it can be -- updated with the new value when available. -link_caf node _is_upd = do +link_caf node = do { dflags <- getDynFlags -- Call the RTS function newCAF, returning the newly-allocated -- blackhole indirection closure diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -44,7 +44,7 @@ import Literal import PrelInfo import Outputable -import Platform +import GHC.Platform import Util import MonadUtils (mapMaybeM) diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} -- | Our extended FCode monad. -- We add a mapping from names to CmmExpr, to support local variable names in @@ -53,7 +54,7 @@ import Unique import UniqSupply -import Control.Monad (liftM, ap) +import Control.Monad (ap) -- | The environment contains variable definitions or blockids. data Named @@ -73,6 +74,7 @@ -- and a list of local declarations. Returns the resulting list of declarations. newtype CmmParse a = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) } + deriving (Functor) type ExtCode = CmmParse () @@ -81,9 +83,6 @@ thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s' - -instance Functor CmmParse where - fmap = liftM instance Applicative CmmParse where pure = returnExtFC diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -34,7 +34,6 @@ import MkGraph import Type import RepType -import TysPrim import CLabel import SMRep import ForeignCall @@ -44,20 +43,26 @@ import UniqSupply import BasicTypes +import TyCoRep +import TysPrim +import Util (zipEqual) + import Control.Monad ----------------------------------------------------------------------------- -- Code generation for Foreign Calls ----------------------------------------------------------------------------- --- | emit code for a foreign call, and return the results to the sequel. --- +-- | Emit code for a foreign call, and return the results to the sequel. +-- Precondition: the length of the arguments list is the same as the +-- arity of the foreign function. cgForeignCall :: ForeignCall -- the op + -> Type -- type of foreign function -> [StgArg] -- x,y arguments -> Type -- result type -> FCode ReturnKind -cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty +cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty = do { dflags <- getDynFlags ; let -- in the stdcall calling convention, the symbol needs @size appended -- to it, where size is the total number of bytes of arguments. We @@ -70,7 +75,7 @@ -- ToDo: this might not be correct for 64-bit API arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) (wORD_SIZE dflags) - ; cmm_args <- getFCallArgs stg_args + ; cmm_args <- getFCallArgs stg_args typ ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of @@ -492,43 +497,131 @@ closureField :: DynFlags -> ByteOff -> ByteOff closureField dflags off = off + fixedHdrSize dflags --- ----------------------------------------------------------------------------- +-- Note [Unlifted boxed arguments to foreign calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- For certain types passed to foreign calls, we adjust the actual --- value passed to the call. For ByteArray#/Array# we pass the --- address of the actual array, not the address of the heap object. +-- value passed to the call. For ByteArray#, Array#, SmallArray#, +-- and ArrayArray#, we pass the address of the array's payload, not +-- the address of the heap object. For example, consider +-- foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () +-- At a Haskell call like `foo x y`, we'll generate a C call that +-- is more like +-- c_foo( x+8, y ) +-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves +-- it past the header words of the ByteArray object to point directly +-- to the data inside the ByteArray#. (The exact offset depends +-- on the target architecture and on profiling) By contrast, (y :: Int#) +-- requires no such adjustment. +-- +-- This adjustment is performed by 'add_shim'. The size of the +-- adjustment depends on the type of heap object. But +-- how can we determine that type? There are two available options. +-- We could use the types of the actual values that the foreign call +-- has been applied to, or we could use the types present in the +-- foreign function's type. Prior to GHC 8.10, we used the former +-- strategy since it's a little more simple. However, in issue #16650 +-- and more compellingly in the comments of +-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was +-- demonstrated that this leads to bad behavior in the presence +-- of unsafeCoerce#. Returning to the above example, suppose the +-- Haskell call looked like +-- foo (unsafeCoerce# p) +-- where the types of expressions comprising the arguments are +-- p :: (Any :: TYPE 'UnliftedRep) +-- i :: Int# +-- so that the unsafe-coerce is between Any and ByteArray#. +-- These two types have the same kind (they are both represented by +-- a heap pointer) so no GC errors will occur if we do this unsafe coerce. +-- By the time this gets to the code generator the cast has been +-- discarded so we have +-- foo p y +-- But we *must* adjust the pointer to p by a ByteArray# shim, +-- *not* by an Any shim (the Any shim involves no offset at all). +-- +-- To avoid this bad behavior, we adopt the second strategy: use +-- the types present in the foreign function's type. +-- In collectStgFArgTypes, we convert the foreign function's +-- type to a list of StgFArgType. Then, in add_shim, we interpret +-- these as numeric offsets. -getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] +getFCallArgs :: + [StgArg] + -> Type -- the type of the foreign function + -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args -- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes - -getFCallArgs args - = do { mb_cmms <- mapM get args +-- Precondition: args and typs have the same length +-- See Note [Unlifted boxed arguments to foreign calls] +getFCallArgs args typ + = do { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ)) ; return (catMaybes mb_cmms) } where - get arg | null arg_reps - = return Nothing - | otherwise - = do { cmm <- getArgAmode (NonVoid arg) - ; dflags <- getDynFlags - ; return (Just (add_shim dflags arg_ty cmm, hint)) } - where - arg_ty = stgArgType arg - arg_reps = typePrimRep arg_ty - hint = typeForeignHint arg_ty + get (arg,typ) + | null arg_reps + = return Nothing + | otherwise + = do { cmm <- getArgAmode (NonVoid arg) + ; dflags <- getDynFlags + ; return (Just (add_shim dflags typ cmm, hint)) } + where + arg_ty = stgArgType arg + arg_reps = typePrimRep arg_ty + hint = typeForeignHint arg_ty -add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr -add_shim dflags arg_ty expr - | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) +-- The minimum amount of information needed to determine +-- the offset to apply to an argument to a foreign call. +-- See Note [Unlifted boxed arguments to foreign calls] +data StgFArgType + = StgPlainType + | StgArrayType + | StgSmallArrayType + | StgByteArrayType - | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon - = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) +-- See Note [Unlifted boxed arguments to foreign calls] +add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr +add_shim dflags ty expr = case ty of + StgPlainType -> expr + StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags) + StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) + StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags) - | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB dflags expr (arrWordsHdrSize dflags) +-- From a function, extract information needed to determine +-- the offset of each argument when used as a C FFI argument. +-- See Note [Unlifted boxed arguments to foreign calls] +collectStgFArgTypes :: Type -> [StgFArgType] +collectStgFArgTypes = go [] + where + -- Skip foralls + go bs (ForAllTy _ res) = go bs res + go bs (AppTy{}) = reverse bs + go bs (TyConApp{}) = reverse bs + go bs (LitTy{}) = reverse bs + go bs (TyVarTy{}) = reverse bs + go _ (CastTy{}) = panic "myCollectTypeArgs: CastTy" + go _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy" + go bs (FunTy {ft_arg = arg, ft_res=res}) = + go (typeToStgFArgType arg:bs) res - | otherwise = expr +-- Choose the offset based on the type. For anything other +-- than an unlifted boxed type, there is no offset. +-- See Note [Unlifted boxed arguments to foreign calls] +typeToStgFArgType :: Type -> StgFArgType +typeToStgFArgType typ + | tycon == arrayPrimTyCon = StgArrayType + | tycon == mutableArrayPrimTyCon = StgArrayType + | tycon == arrayArrayPrimTyCon = StgArrayType + | tycon == mutableArrayArrayPrimTyCon = StgArrayType + | tycon == smallArrayPrimTyCon = StgSmallArrayType + | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType + | tycon == byteArrayPrimTyCon = StgByteArrayType + | tycon == mutableByteArrayPrimTyCon = StgByteArrayType + | otherwise = StgPlainType where - tycon = tyConAppTyCon (unwrapType arg_ty) - -- should be a tycon app, since this is a foreign call + -- Should be a tycon app, since this is a foreign call. We look + -- through newtypes so the offset does not change if a user replaces + -- a type in a foreign function signature with a representationally + -- equivalent newtype. + tycon = tyConAppTyCon (unwrapType typ) + diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- @@ -111,9 +112,7 @@ -------------------------------------------------------- newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } - -instance Functor FCode where - fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s') + deriving (Functor) instance Applicative FCode where pure val = FCode (\_info_down state -> (val, state)) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -31,7 +31,7 @@ import StgCmmProf ( costCentreFrom ) import DynFlags -import Platform +import GHC.Platform import BasicTypes import BlockId import MkGraph @@ -71,8 +71,8 @@ -> FCode ReturnKind -- Foreign calls -cgOpApp (StgFCallOp fcall _) stg_args res_ty - = cgForeignCall fcall stg_args res_ty +cgOpApp (StgFCallOp fcall ty) stg_args res_ty + = cgForeignCall fcall ty stg_args res_ty -- Note [Foreign call results] -- tagToEnum# is special: we need to pull the constructor @@ -669,7 +669,7 @@ -- SIMD primops emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do checkVecCompatibility dflags vcat n w - doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res + doVecBroadcastOp (vecElemInjectCast dflags vcat w) ty zeros e res where zeros :: CmmExpr zeros = CmmLit $ CmmVec (replicate n zero) @@ -1513,7 +1513,9 @@ callishOp DoubleAcoshOp = Just MO_F64_Acosh callishOp DoubleAtanhOp = Just MO_F64_Atanh callishOp DoubleLogOp = Just MO_F64_Log +callishOp DoubleLog1POp = Just MO_F64_Log1P callishOp DoubleExpOp = Just MO_F64_Exp +callishOp DoubleExpM1Op = Just MO_F64_ExpM1 callishOp DoubleSqrtOp = Just MO_F64_Sqrt callishOp FloatPowerOp = Just MO_F32_Pwr @@ -1530,7 +1532,9 @@ callishOp FloatAcoshOp = Just MO_F32_Acosh callishOp FloatAtanhOp = Just MO_F32_Atanh callishOp FloatLogOp = Just MO_F32_Log +callishOp FloatLog1POp = Just MO_F32_Log1P callishOp FloatExpOp = Just MO_F32_Exp +callishOp FloatExpM1Op = Just MO_F32_ExpM1 callishOp FloatSqrtOp = Just MO_F32_Sqrt callishOp _ = Nothing @@ -1761,9 +1765,8 @@ checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility dflags vcat l w = do - when (hscTarget dflags /= HscLlvm) $ do - sorry $ unlines ["SIMD vector instructions require the LLVM back-end." - ,"Please use -fllvm."] + when (hscTarget dflags /= HscLlvm && hscTarget dflags /= HscAsm) $ do + sorry "SIMD vector instructions not supported for the C backend or GHCi" check vecWidth vcat l w where check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () @@ -1788,7 +1791,39 @@ ------------------------------------------------------------------------------ -- Helpers for translating vector packing and unpacking. +doVecBroadcastOp :: Maybe MachOp -- Cast from element to vector component + -> CmmType -- Type of vector + -> CmmExpr -- Initial vector + -> CmmExpr -- Elements + -> CmmFormal -- Destination for result + -> FCode () +doVecBroadcastOp maybe_pre_write_cast ty z es res = do + dst <- newTemp ty + emitAssign (CmmLocal dst) z + vecBroadcast dst es 0 + where + vecBroadcast :: CmmFormal -> CmmExpr -> Int -> FCode () + vecBroadcast src e _ = do + dst <- newTemp ty + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Broadcast len wid) + [CmmReg (CmmLocal src), cast e]) + --TODO : Add the MachOp MO_V_Broadcast + else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) + [CmmReg (CmmLocal src), cast e]) + emitAssign (CmmLocal res) (CmmReg (CmmLocal dst)) + cast :: CmmExpr -> CmmExpr + cast val = case maybe_pre_write_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + doVecPackOp :: Maybe MachOp -- Cast from element to vector component -> CmmType -- Type of vector -> CmmExpr -- Initial vector @@ -1805,16 +1840,16 @@ emitAssign (CmmLocal res) (CmmReg (CmmLocal src)) vecPack src (e : es) i = do - dst <- newTemp ty - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) - else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) - vecPack dst es (i + 1) + dst <- newTemp ty + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) + [CmmReg (CmmLocal src), cast e, iLit]) + else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) + [CmmReg (CmmLocal src), cast e, iLit]) + vecPack dst es (i + 1) where -- vector indices are always 32-bits - iLit = CmmLit (CmmInt (toInteger i) W32) + iLit = CmmLit (CmmInt ((toInteger i) * 16) W32) cast :: CmmExpr -> CmmExpr cast val = case maybe_pre_write_cast of diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} module CoreLint ( lintCoreBindings, lintUnfolding, @@ -2076,6 +2077,7 @@ LintEnv -> WarnsAndErrs -> -- Warning and error messages so far (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + deriving (Functor) type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) @@ -2145,9 +2147,6 @@ lint the result. Reason: want to check that synonyms are saturated when the type is expanded. -} - -instance Functor LintM where - fmap = liftM instance Applicative LintM where pure x = LintM $ \ _ errs -> (Just x, errs) diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -53,7 +53,7 @@ import Util import Pair import Outputable -import Platform +import GHC.Platform import FastString import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) @@ -71,7 +71,7 @@ The goal of this pass is to prepare for code generation. -1. Saturate constructor and primop applications. +1. Saturate constructor applications. 2. Convert to A-normal form; that is, function arguments are always variables. @@ -1063,8 +1063,21 @@ -- Building the saturated syntax -- --------------------------------------------------------------------------- -maybeSaturate deals with saturating primops and constructors -The type is the type of the entire application +Note [Eta expansion of hasNoBinding things in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +maybeSaturate deals with eta expanding to saturate things that can't deal with +unsaturated applications (identified by 'hasNoBinding', currently just +foreign calls and unboxed tuple/sum constructors). + +Note that eta expansion in CorePrep is very fragile due to the "prediction" of +CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta +expansion in CorePrep] in TidyPgm for details. We previously saturated primop +applications here as well but due to this fragility (see #16846) we now deal +with this another way, as described in Note [Primop wrappers] in PrimOp. + +It's quite likely that eta expansion of constructor applications will +eventually break in a similar way to how primops did. We really should +eliminate this case as well. -} maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -25,6 +25,7 @@ import GhcPrelude import TmOracle +import PmPpr import Unify( tcMatchTy ) import DynFlags import HsSyn @@ -579,7 +580,7 @@ pmInitialTmTyCs :: PmM Delta pmInitialTmTyCs = do ty_cs <- liftD getDictsDs - tm_cs <- map toComplex . bagToList <$> liftD getTmCsDs + tm_cs <- bagToList <$> liftD getTmCsDs sat_ty <- tyOracle ty_cs let initTyCs = if sat_ty then ty_cs else emptyBag initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs) @@ -627,7 +628,7 @@ pmIsSatisfiable :: Delta -- ^ The ambient term and type constraints -- (known to be satisfiable). - -> ComplexEq -- ^ The new term constraint. + -> TmVarCt -- ^ The new term constraint. -> Bag EvVar -- ^ The new type constraints. -> [Type] -- ^ The strict argument types. -> PmM (Maybe Delta) @@ -653,7 +654,7 @@ tmTyCsAreSatisfiable :: Delta -- ^ The ambient term and type constraints -- (known to be satisfiable). - -> ComplexEq -- ^ The new term constraint. + -> TmVarCt -- ^ The new term constraint. -> Bag EvVar -- ^ The new type constraints. -> PmM (Maybe Delta) -- ^ @'Just' delta@ if the constraints (@delta@) are @@ -1463,7 +1464,7 @@ data InhabitationCandidate = InhabitationCandidate { ic_val_abs :: ValAbs - , ic_tm_ct :: ComplexEq + , ic_tm_ct :: TmVarCt , ic_ty_cs :: Bag EvVar , ic_strict_arg_tys :: [Type] } @@ -1660,7 +1661,7 @@ strict_arg_tys = filterByList arg_is_banged arg_tys' return $ InhabitationCandidate { ic_val_abs = con_abs - , ic_tm_ct = (PmExprVar (idName x), vaToPmExpr con_abs) + , ic_tm_ct = TVC x (vaToPmExpr con_abs) , ic_ty_cs = listToBag evvars , ic_strict_arg_tys = strict_arg_tys } @@ -1678,21 +1679,15 @@ | PmExprOther {} <- expr -> pure PmFake | otherwise -> pure (PmGrd pv expr) --- | Create a term equality of the form: `(False ~ (x ~ lit))` -mkNegEq :: Id -> PmLit -> ComplexEq -mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l) -{-# INLINE mkNegEq #-} - -- | Create a term equality of the form: `(x ~ lit)` -mkPosEq :: Id -> PmLit -> ComplexEq -mkPosEq x l = (PmExprVar (idName x), PmExprLit l) +mkPosEq :: Id -> PmLit -> TmVarCt +mkPosEq x l = TVC x (PmExprLit l) {-# INLINE mkPosEq #-} -- | Create a term equality of the form: `(x ~ x)` -- (always discharged by the term oracle) -mkIdEq :: Id -> ComplexEq -mkIdEq x = (PmExprVar name, PmExprVar name) - where name = idName x +mkIdEq :: Id -> TmVarCt +mkIdEq x = TVC x (PmExprVar (idName x)) {-# INLINE mkIdEq #-} -- | Generate a variable pattern of a given type @@ -2059,8 +2054,7 @@ -- Var pmcheckHd (PmVar x) ps guards va (ValVec vva delta) - | Just tm_state <- solveOneEq (delta_tm_cs delta) - (PmExprVar (idName x), vaToPmExpr va) + | Just tm_state <- solveOneEq (delta_tm_cs delta) (TVC x (vaToPmExpr va)) = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state})) | otherwise = return mempty @@ -2122,7 +2116,8 @@ ValVec vva (delta {delta_tm_cs = tm_state}) Nothing -> return mempty where - us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l) + -- See Note [Refutable shapes] in TmOracle + us | Just tm_state <- addSolveRefutableAltCon (delta_tm_cs delta) x (PmAltLit l) = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })] | otherwise = [] @@ -2142,7 +2137,8 @@ (ValVec vva (delta { delta_tm_cs = tm_state })) | otherwise = return non_matched where - us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l) + -- See Note [Refutable shapes] in TmOracle + us | Just tm_state <- addSolveRefutableAltCon (delta_tm_cs delta) x (PmAltLit l) = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })] | otherwise = [] @@ -2407,22 +2403,22 @@ genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee -> [Pat GhcTc] -- LHS (should have length 1) -> [Id] -- MatchVars (should have length 1) - -> DsM (Bag SimpleEq) + -> DsM (Bag TmVarCt) genCaseTmCs2 Nothing _ _ = return emptyBag genCaseTmCs2 (Just scr) [p] [var] = do fam_insts <- dsGetFamInstEnvs [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p let scr_e = lhsExprToPmExpr scr - return $ listToBag [(var, e), (var, scr_e)] + return $ listToBag [(TVC var e), (TVC var scr_e)] genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase" -- | Generate a simple equality when checking a case expression: -- case x of { matches } -- When checking matches we record that (x ~ y) where y is the initial -- uncovered. All matches will have to satisfy this equality. -genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq +genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag TmVarCt genCaseTmCs1 Nothing _ = emptyBag -genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr) +genCaseTmCs1 (Just scr) [var] = unitBag (TVC var (lhsExprToPmExpr scr)) genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase" {- Note [Literals in PmPat] @@ -2484,21 +2480,15 @@ instance Outputable ValVec where ppr (ValVec vva delta) - = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta) - vector = substInValAbs subst vva - in ppr_uncovered (vector, residual_eqs) + = let (subst, refuts) = wrapUpTmState (delta_tm_cs delta) + vector = substInValAbs subst vva + in pprUncovered (vector, refuts) -- | Apply a term substitution to a value vector abstraction. All VAs are -- transformed to PmExpr (used only before pretty printing). -substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr] +substInValAbs :: TmVarCtEnv -> [ValAbs] -> [PmExpr] substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr) --- | Wrap up the term oracle's state once solving is complete. Drop any --- information about unhandled constraints (involving HsExprs) and flatten --- (height 1) the substitution. -wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv) -wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst) - -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility) dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM () dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result @@ -2538,10 +2528,11 @@ maxPatterns = maxUncoveredPatterns dflags -- Print a single clause (for redundant/with-inaccessible-rhs) - pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q + pprEqn q txt = pprContext True ctx (text txt) $ \f -> + f (pprPats kind (map unLoc q)) -- Print several clauses (for uncovered clauses) - pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ -> + pprEqns qs = pprContext False ctx (text "are non-exhaustive") $ \_ -> case qs of -- See #11245 [ValVec [] _] -> text "Guards do not cover entire pattern space" @@ -2552,7 +2543,7 @@ -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for -- which we only know the type and have no inhabitants at hand) - warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ -> + warnEmptyCase ty = pprContext False ctx (text "are non-exhaustive") $ \_ -> hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty) {- Note [Inaccessible warnings for record updates] @@ -2589,7 +2580,7 @@ msg is = fsep [ text "Pattern match checker exceeded" , parens (ppr is), text "iterations in", ctxt <> dot , text "(Use -fmax-pmcheck-iterations=n" - , text "to set the maximun number of iterations to n)" ] + , text "to set the maximum number of iterations to n)" ] flag_i = wopt Opt_WarnOverlappingPatterns dflags flag_u = exhaustive dflags kind @@ -2624,8 +2615,8 @@ -- incomplete -- True <==> singular -pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc -pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun +pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc +pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun = vcat [text txt <+> msg, sep [ text "In" <+> ppr_match <> char ':' , nest 4 (rest_of_msg_fun pref)]] @@ -2639,87 +2630,10 @@ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) -ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc -ppr_pats kind pats +pprPats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc +pprPats kind pats = sep [sep (map ppr pats), matchSeparator kind, text "..."] -ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc -ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn)) - -ppr_constraint :: (SDoc,[PmLit]) -> SDoc -ppr_constraint (var, lits) = var <+> text "is not one of" - <+> braces (pprWithCommas ppr lits) - -ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc -ppr_uncovered (expr_vec, complex) - | null cs = fsep vec -- there are no literal constraints - | otherwise = hang (fsep vec) 4 $ - text "where" <+> vcat (map ppr_constraint cs) - where - sdoc_vec = mapM pprPmExprWithParens expr_vec - (vec,cs) = runPmPprM sdoc_vec (filterComplex complex) - -{- Note [Representation of Term Equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the paper, term constraints always take the form (x ~ e). Of course, a more -general constraint of the form (e1 ~ e1) can always be transformed to an -equivalent set of the former constraints, by introducing a fresh, intermediate -variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise -to #11160 (incredibly bad performance for literal pattern matching). Two are -the main sources of this problem (the actual problem is how these two interact -with each other): - -1. Pattern matching on literals generates twice as many constraints as needed. - Consider the following (tests/ghci/should_run/ghcirun004): - - foo :: Int -> Int - foo 1 = 0 - ... - foo 5000 = 4999 - - The covered and uncovered set *should* look like: - U0 = { x |> {} } - - C1 = { 1 |> { x ~ 1 } } - U1 = { x |> { False ~ (x ~ 1) } } - ... - C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } } - U10 = { x |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } } - ... - - If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) } - we get twice as many constraints. Also note that half of them are just the - substitution [x |-> False]. - -2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form - (x ~ e) as substitutions [x |-> e]. More specifically, function - `extendSubstAndSolve` applies such substitutions in the residual constraints - and partitions them in the affected and non-affected ones, which are the new - worklist. Essentially, this gives quadradic behaviour on the number of the - residual constraints. (This would not be the case if the term oracle used - mutable variables but, since we use it to handle disjunctions on value set - abstractions (`Union` case), we chose a pure, incremental interface). - -Now the problem becomes apparent (e.g. for clause 300): - * Set U300 contains 300 substituting constraints [y_i |-> False] and 300 - constraints that we know that will not reduce (stay in the worklist). - * To check for consistency, we apply the substituting constraints ONE BY ONE - (since `tmOracle` is called incrementally, it does not have all of them - available at once). Hence, we go through the (non-progressing) constraints - over and over, achieving over-quadradic behaviour. - -If instead we allow constraints of the form (e ~ e), - * All uncovered sets Ui contain no substituting constraints and i - non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle - behaves linearly. - * All covered sets Ci contain exactly (i-1) non-progressing constraints and - a single substituting constraint. So the term oracle goes through the - constraints only once. - -The performance improvement becomes even more important when more arguments are -involved. --} - -- Debugging Infrastructre tracePm :: String -> SDoc -> PmM () @@ -2757,3 +2671,5 @@ pprValVecDebug :: ValVec -> SDoc pprValVecDebug (ValVec vas _d) = text "ValVec" <+> parens (pprValAbs vas) + -- $$ ppr (delta_tm_cs _d) + -- $$ ppr (delta_ty_cs _d) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} module Coverage (addTicksToBinds, hpcInitCode) where @@ -1071,11 +1072,9 @@ -- over what free variables we track. data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } + deriving (Functor) -- a combination of a state monad (TickTransState) and a writer -- monad (FreeVars). - -instance Functor TM where - fmap = liftM instance Applicative TM where pure a = TM $ \ _env st -> (a,noFVs,st) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -1091,7 +1091,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We cannot have levity polymorphic function arguments. See Note [Levity polymorphism invariants] in CoreSyn. But we *can* have -functions that take levity polymorphism arguments, as long as these +functions that take levity polymorphic arguments, as long as these functions are eta-reduced. (See #12708 for an example.) However, we absolutely cannot do this for functions that have no @@ -1162,7 +1162,11 @@ levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () levPolyPrimopErr primop ty bad_tys - = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:") - 2 (ppr primop <+> dcolon <+> pprWithTYPE ty) - , hang (text "Levity-polymorphic arguments:") - 2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ] + = errDs $ vcat + [ hang (text "Cannot use function with levity-polymorphic arguments:") + 2 (ppr primop <+> dcolon <+> pprWithTYPE ty) + , hang (text "Levity-polymorphic arguments:") + 2 $ vcat $ map + (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) + bad_tys + ] diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -49,7 +49,7 @@ import Outputable import FastString import DynFlags -import Platform +import GHC.Platform import OrdList import Pair import Util diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1332,13 +1332,21 @@ = notHandled "monad comprehension and [: :]" (ppr e) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } -repE e@(ExplicitTuple _ es boxed) - | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es] - ; repTup xs } - | otherwise = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es] - ; repUnboxedTup xs } +repE (ExplicitTuple _ es boxity) = + let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ)) + tupArgToCoreExp a + | L _ (Present _ e) <- dL a = do { e' <- repLE e + ; coreJust expQTyConName e' } + | otherwise = coreNothing expQTyConName + in do { args <- mapM tupArgToCoreExp es + ; expQTy <- lookupType expQTyConName + ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy] + listArg = coreList' maybeExpQTy args + ; if isBoxed boxity + then repTup listArg + else repUnboxedTup listArg } + repE (ExplicitSum _ alt arity e) = do { e1 <- repLE e ; repUnboxedSum e1 alt arity } @@ -2077,10 +2085,10 @@ repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) repLamCase (MkC ms) = rep2 lamCaseEName [ms] -repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [es] -repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ) diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -396,11 +396,11 @@ = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) }) -- | Get in-scope term constraints (pm check) -getTmCsDs :: DsM (Bag SimpleEq) +getTmCsDs :: DsM (Bag TmVarCt) getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) } -- | Add in-scope term constraints (pm check) -addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a +addTmCsDs :: Bag TmVarCt -> DsM a -> DsM a addTmCsDs tm_cs = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) }) diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -20,6 +20,7 @@ import TcRnTypes import Control.Applicative +import Data.Bifunctor (first) import Data.List import Data.Map (Map) import qualified Data.Map as M @@ -214,9 +215,10 @@ InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) RecCon _ -> go 1 ret where - go n (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys - go n (_ : tys) = go (n+1) tys - go _ [] = M.empty + go n = M.fromList . catMaybes . zipWith f [n..] + where + f n (HsDocTy _ _ lds) = Just (n, unLoc lds) + f _ _ = Nothing ret = case con of ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] @@ -262,14 +264,13 @@ typeDocs :: HsType GhcRn -> Map Int (HsDocString) typeDocs = go 0 where - go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) - go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy _ (dL->L _ - (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) = - M.insert n x $ go (n+1) ty - go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc - go _ _ = M.empty + go n = \case + HsForAllTy { hst_body = ty } -> go n (unLoc ty) + HsQualTy { hst_body = ty } -> go n (unLoc ty) + HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) + HsFunTy _ _ ty -> go (n+1) (unLoc ty) + HsDocTy _ _ doc -> M.singleton n (unLoc doc) + _ -> M.empty -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. @@ -289,11 +290,11 @@ mkDecls (valbinds . hs_valds) (ValD noExt) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs - typesigs _ = error "expected ValBindsOut" + typesigs ValBinds{} = error "expected XValBindsLR" valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds - valbinds _ = error "expected ValBindsOut" + valbinds ValBinds{} = error "expected XValBindsLR" -- | Sort by source location sortByLoc :: [Located a] -> [Located a] @@ -304,17 +305,16 @@ -- A declaration may have multiple doc strings attached to it. collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] -- ^ This is an example. -collectDocs = go Nothing [] +collectDocs = go [] Nothing where - go Nothing _ [] = [] - go (Just prev) docs [] = finished prev docs [] - go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds) - | Nothing <- prev = go Nothing (str:docs) ds - | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) = - go prev (str:docs) ds - go Nothing docs (d:ds) = go (Just d) docs ds - go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) + go docs mprev decls = case (decls, mprev) of + ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds + ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds + ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds + (d : ds, Nothing) -> go docs (Just d) ds + (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds + ([] , Nothing) -> [] + ([] , Just prev) -> finished prev docs [] finished decl docs rest = (decl, reverse docs) : rest @@ -335,13 +335,12 @@ -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses decls = [ if isClassD d then (cL loc (filterClass d), doc) else x - | x@(dL->L loc d, doc) <- decls ] +filterClasses = map (first (mapLoc filterClass)) where - filterClass (TyClD x c) = + filterClass (TyClD x c@(ClassDecl {})) = TyClD x $ c { tcdSigs = filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } - filterClass _ = error "expected TyClD" + filterClass d = d -- | Was this signature given by the user? isUserSig :: Sig name -> Bool @@ -350,12 +349,10 @@ isUserSig PatSynSig {} = True isUserSig _ = False -isClassD :: HsDecl a -> Bool -isClassD (TyClD _ d) = isClassDecl d -isClassD _ = False - -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor -mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -mkDecls field con struct = [ cL loc (con decl) - | (dL->L loc decl) <- field struct ] +mkDecls :: (struct -> [Located decl]) + -> (decl -> hsDecl) + -> struct + -> [Located hsDecl] +mkDecls field con = map (mapLoc con) . field diff --git a/compiler/deSugar/PmPpr.hs b/compiler/deSugar/PmPpr.hs new file mode 100644 --- /dev/null +++ b/compiler/deSugar/PmPpr.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} + +-- | Provides factilities for pretty-printing 'PmExpr's in a way approriate for +-- user facing pattern match warnings. +module PmPpr ( + pprUncovered + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Name +import NameEnv +import NameSet +import UniqDFM +import UniqSet +import ConLike +import DataCon +import TysWiredIn +import Outputable +import Control.Monad.Trans.State.Strict +import Maybes +import Util + +import TmOracle + +-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its +-- components and refutable shapes associated to any mentioned variables. +-- +-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]]): +-- +-- @ +-- (Just p) q +-- where p is not one of {3, 4} +-- q is not one of {0, 5} +-- @ +pprUncovered :: ([PmExpr], PmRefutEnv) -> SDoc +pprUncovered (expr_vec, refuts) + | null cs = fsep vec -- there are no literal constraints + | otherwise = hang (fsep vec) 4 $ + text "where" <+> vcat (map pprRefutableShapes cs) + where + sdoc_vec = mapM pprPmExprWithParens expr_vec + (vec,cs) = runPmPpr sdoc_vec (prettifyRefuts refuts) + +-- | Output refutable shapes of a variable in the form of @var is not one of {2, +-- Nothing, 3}@. +pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc +pprRefutableShapes (var, alts) + = var <+> text "is not one of" <+> braces (pprWithCommas ppr_alt alts) + where + ppr_alt (PmAltLit lit) = ppr lit + +{- 1. Literals +~~~~~~~~~~~~~~ +Starting with a function definition like: + + f :: Int -> Bool + f 5 = True + f 6 = True + +The uncovered set looks like: + { var |> var /= 5, var /= 6 } + +Yet, we would like to print this nicely as follows: + x , where x not one of {5,6} + +Since these variables will be shown to the programmer, we give them better names +(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'. + +2. Residual Constraints +~~~~~~~~~~~~~~~~~~~~~~~ +Unhandled constraints that refer to HsExpr are typically ignored by the solver +(it does not even substitute in HsExpr so they are even printed as wildcards). +Additionally, the oracle returns a substitution if it succeeds so we apply this +substitution to the vectors before printing them out (see function `pprOne' in +Check.hs) to be more precise. +-} + +-- | A 'PmRefutEnv' with pretty names for the occuring variables. +type PrettyPmRefutEnv = DNameEnv (SDoc, [PmAltCon]) + +-- | Assigns pretty names to constraint variables in the domain of the given +-- 'PmRefutEnv'. +prettifyRefuts :: PmRefutEnv -> PrettyPmRefutEnv +prettifyRefuts = listToUDFM . zipWith rename nameList . udfmToList + where + rename new (old, lits) = (old, (new, lits)) + -- Try nice names p,q,r,s,t before using the (ugly) t_i + nameList :: [SDoc] + nameList = map text ["p","q","r","s","t"] ++ + [ text ('t':show u) | u <- [(0 :: Int)..] ] + +type PmPprM a = State (PrettyPmRefutEnv, NameSet) a +-- (the first part of the state is read only. make it a reader?) + +runPmPpr :: PmPprM a -> PrettyPmRefutEnv -> (a, [(SDoc,[PmAltCon])]) +runPmPpr m lit_env = (result, mapMaybe is_used (udfmToList lit_env)) + where + (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet) + + is_used (k,v) + | elemUniqSet_Directly k used = Just v + | otherwise = Nothing + +addUsed :: Name -> PmPprM () +addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x)) + +checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated +checkNegation x = do + negated <- gets fst + return $ case lookupDNameEnv negated x of + Just (new, _) -> Just new + Nothing -> Nothing + +-- | Pretty print a pmexpr, but remember to prettify the names of the variables +-- that refer to neg-literals. The ones that cannot be shown are printed as +-- underscores. +pprPmExpr :: PmExpr -> PmPprM SDoc +pprPmExpr (PmExprVar x) = do + mb_name <- checkNegation x + case mb_name of + Just name -> addUsed x >> return name + Nothing -> return underscore +pprPmExpr (PmExprCon con args) = pprPmExprCon con args +pprPmExpr (PmExprLit l) = return (ppr l) +pprPmExpr (PmExprOther _) = return underscore -- don't show + +needsParens :: PmExpr -> Bool +needsParens (PmExprVar {}) = False +needsParens (PmExprLit l) = isNegatedPmLit l +needsParens (PmExprOther {}) = False -- will become a wildcard +needsParens (PmExprCon (RealDataCon c) es) + | isTupleDataCon c + || isConsDataCon c || null es = False + | otherwise = True +needsParens (PmExprCon (PatSynCon _) es) = not (null es) + +pprPmExprWithParens :: PmExpr -> PmPprM SDoc +pprPmExprWithParens expr + | needsParens expr = parens <$> pprPmExpr expr + | otherwise = pprPmExpr expr + +pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc +pprPmExprCon (RealDataCon con) args + | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args + | isConsDataCon con = pretty_list + where + mkTuple :: [SDoc] -> SDoc + mkTuple = parens . fsep . punctuate comma + + -- lazily, to be used in the list case only + pretty_list :: PmPprM SDoc + pretty_list = case isNilPmExpr (last list) of + True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list) + False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list + + list = list_elements args + + list_elements [x,y] + | PmExprCon c es <- y, RealDataCon nilDataCon == c + = ASSERT(null es) [x,y] + | PmExprCon c es <- y, RealDataCon consDataCon == c + = x : list_elements es + | otherwise = [x,y] + list_elements list = pprPanic "list_elements:" (ppr list) +pprPmExprCon cl args + | conLikeIsInfix cl = case args of + [x, y] -> do x' <- pprPmExprWithParens x + y' <- pprPmExprWithParens y + return (x' <+> ppr cl <+> y') + -- can it be infix but have more than two arguments? + list -> pprPanic "pprPmExprCon:" (ppr list) + | null args = return (ppr cl) + | otherwise = do args' <- mapM pprPmExprWithParens args + return (fsep (ppr cl : args')) + +-- | Check whether a literal is negated +isNegatedPmLit :: PmLit -> Bool +isNegatedPmLit (PmOLit b _) = b +isNegatedPmLit _other_lit = False + +-- | Check whether a PmExpr is syntactically e +isNilPmExpr :: PmExpr -> Bool +isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon +isNilPmExpr _other_expr = False + +-- | Check if a DataCon is (:). +isConsDataCon :: DataCon -> Bool +isConsDataCon con = consDataCon == con diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs --- a/compiler/deSugar/TmOracle.hs +++ b/compiler/deSugar/TmOracle.hs @@ -1,23 +1,27 @@ {- Author: George Karachalias - -The term equality oracle. The main export of the module is function `tmOracle'. -} {-# LANGUAGE CPP, MultiWayIf #-} +-- | The term equality oracle. The main export of the module are the functions +-- 'tmOracle', 'solveOneEq' and 'addSolveRefutableAltCon'. +-- +-- If you are looking for an oracle that can solve type-level constraints, look +-- at 'TcSimplify.tcCheckSatisfiability'. module TmOracle ( -- re-exported from PmExpr - PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr, - eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr, - hsExprToPmExpr, pprPmExprWithParens, + PmExpr(..), PmLit(..), PmAltCon(..), TmVarCt(..), TmVarCtEnv, + PmRefutEnv, eqPmLit, isNotPmExprOther, lhsExprToPmExpr, hsExprToPmExpr, -- the term oracle - tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge, + tmOracle, TmState, initialTmState, wrapUpTmState, solveOneEq, + extendSubst, canDiverge, isRigid, + addSolveRefutableAltCon, lookupRefutableAltCons, -- misc. - toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv + exprDeepLookup, pmLitType ) where #include "HsVersions.h" @@ -26,16 +30,19 @@ import PmExpr +import Util import Id import Name import Type import HsLit import TcHsSyn import MonadUtils -import Util +import ListSetOps (insertNoDup, unionLists) +import Maybes import Outputable - import NameEnv +import UniqFM +import UniqDFM {- %************************************************************************ @@ -45,202 +52,261 @@ %************************************************************************ -} --- | The type of substitutions. -type PmVarEnv = NameEnv PmExpr +-- | Pretty much a @['TmVarCt']@ association list where the domain is 'Name' +-- instead of 'Id'. This is the type of 'tm_pos', where we store solutions for +-- rigid pattern match variables. +type TmVarCtEnv = NameEnv PmExpr --- | The environment of the oracle contains --- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)). --- 2. A substitution we extend with every step and return as a result. -type TmOracleEnv = (Bool, PmVarEnv) +-- | An environment assigning shapes to variables that immediately lead to a +-- refutation. So, if this maps @x :-> [3]@, then trying to solve a 'TmVarCt' +-- like @x ~ 3@ immediately leads to a contradiction. +-- Determinism is important since we use this for warning messages in +-- 'PmPpr.pprUncovered'. We don't do the same for 'TmVarCtEnv', so that is a plain +-- 'NameEnv'. +-- +-- See also Note [Refutable shapes] in TmOracle. +type PmRefutEnv = DNameEnv [PmAltCon] +-- | The state of the term oracle. Tracks all term-level facts of the form "x is +-- @True@" ('tm_pos') and "x is not @5@" ('tm_neg'). +-- +-- Subject to Note [The Pos/Neg invariant]. +data TmState = TmS + { tm_pos :: !TmVarCtEnv + -- ^ A substitution with solutions we extend with every step and return as a + -- result. The substitution is in /triangular form/: It might map @x@ to @y@ + -- where @y@ itself occurs in the domain of 'tm_pos', rendering lookup + -- non-idempotent. This means that 'varDeepLookup' potentially has to walk + -- along a chain of var-to-var mappings until we find the solution but has the + -- advantage that when we update the solution for @y@ above, we automatically + -- update the solution for @x@ in a union-find-like fashion. + -- Invariant: Only maps to other variables ('PmExprVar') or to WHNFs + -- ('PmExprLit', 'PmExprCon'). Ergo, never maps to a 'PmExprOther'. + , tm_neg :: !PmRefutEnv + -- ^ Maps each variable @x@ to a list of 'PmAltCon's that @x@ definitely + -- cannot match. Example, @x :-> [3, 4]@ means that @x@ cannot match a literal + -- 3 or 4. Should we later solve @x@ to a variable @y@ + -- ('extendSubstAndSolve'), we merge the refutable shapes of @x@ into those of + -- @y@. See also Note [The Pos/Neg invariant]. + } + +{- Note [The Pos/Neg invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant: In any 'TmState', The domains of 'tm_pos' and 'tm_neg' are disjoint. + +For example, it would make no sense to say both + tm_pos = [...x :-> 3 ...] + tm_neg = [...x :-> [4,42]... ] +The positive information is strictly more informative than the negative. + +Suppose we are adding the (positive) fact @x :-> e@ to 'tm_pos'. Then we must +delete any binding for @x@ from 'tm_neg', to uphold the invariant. + +But there is more! Suppose we are adding @x :-> y@ to 'tm_pos', and 'tm_neg' +contains @x :-> cs, y :-> ds@. Then we want to update 'tm_neg' to +@y :-> (cs ++ ds)@, to make use of the negative information we have about @x@. +-} + +instance Outputable TmState where + ppr state = braces (fsep (punctuate comma (pos ++ neg))) + where + pos = map pos_eq (nonDetUFMToList (tm_pos state)) + neg = map neg_eq (udfmToList (tm_neg state)) + pos_eq (l, r) = ppr l <+> char '~' <+> ppr r + neg_eq (l, r) = ppr l <+> char '≁' <+> ppr r + +-- | Initial state of the oracle. +initialTmState :: TmState +initialTmState = TmS emptyNameEnv emptyDNameEnv + +-- | Wrap up the term oracle's state once solving is complete. Return the +-- flattened 'tm_pos' and 'tm_neg'. +wrapUpTmState :: TmState -> (TmVarCtEnv, PmRefutEnv) +wrapUpTmState solver_state + = (flattenTmVarCtEnv (tm_pos solver_state), tm_neg solver_state) + +-- | Flatten the triangular subsitution. +flattenTmVarCtEnv :: TmVarCtEnv -> TmVarCtEnv +flattenTmVarCtEnv env = mapNameEnv (exprDeepLookup env) env + -- | Check whether a constraint (x ~ BOT) can succeed, -- given the resulting state of the term oracle. canDiverge :: Name -> TmState -> Bool -canDiverge x (standby, (_unhandled, env)) +canDiverge x TmS{ tm_pos = pos, tm_neg = neg } -- If the variable seems not evaluated, there is a possibility for - -- constraint x ~ BOT to be satisfiable. - | PmExprVar y <- varDeepLookup env x -- seems not forced - -- If it is involved (directly or indirectly) in any equality in the - -- worklist, we can assume that it is already indirectly evaluated, - -- as a side-effect of equality checking. If not, then we can assume - -- that the constraint is satisfiable. - = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby - -- Variable x is already in WHNF so the constraint is non-satisfiable + -- constraint x ~ BOT to be satisfiable. That's the case when we haven't found + -- a solution (i.e. some equivalent literal or constructor) for it yet. + | (_, PmExprVar y) <- varDeepLookup pos x -- seems not forced + -- Even if we don't have a solution yet, it might be involved in a negative + -- constraint, in which case we must already have evaluated it earlier. + , Nothing <- lookupDNameEnv neg y + = True + -- Variable x is already in WHNF or we know some refutable shape, so the + -- constraint is non-satisfiable | otherwise = False - where - isForcedByEq :: Name -> ComplexEq -> Bool - isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2 +-- | Check whether the equality @x ~ e@ leads to a refutation. Make sure that +-- @x@ and @e@ are completely substituted before! +isRefutable :: Name -> PmExpr -> PmRefutEnv -> Bool +isRefutable x e env + = fromMaybe False $ elem <$> exprToAlt e <*> lookupDNameEnv env x --- | Check whether a variable is in the free variables of an expression -varIn :: Name -> PmExpr -> Bool -varIn x e = case e of - PmExprVar y -> x == y - PmExprCon _ es -> any (x `varIn`) es - PmExprLit _ -> False - PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2) - PmExprOther _ -> False +-- | Solve an equality (top-level). +solveOneEq :: TmState -> TmVarCt -> Maybe TmState +solveOneEq solver_env (TVC x e) = unify solver_env (PmExprVar (idName x), e) --- | Flatten the DAG (Could be improved in terms of performance.). -flattenPmVarEnv :: PmVarEnv -> PmVarEnv -flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env +exprToAlt :: PmExpr -> Maybe PmAltCon +exprToAlt (PmExprLit l) = Just (PmAltLit l) +exprToAlt _ = Nothing --- | The state of the term oracle (includes complex constraints that cannot --- progress unless we get more information). -type TmState = ([ComplexEq], TmOracleEnv) +-- | Record that a particular 'Id' can't take the shape of a 'PmAltCon' in the +-- 'TmState' and return @Nothing@ if that leads to a contradiction. +addSolveRefutableAltCon :: TmState -> Id -> PmAltCon -> Maybe TmState +addSolveRefutableAltCon original@TmS{ tm_pos = pos, tm_neg = neg } x nalt + = case exprToAlt e of + -- We have to take care to preserve Note [The Pos/Neg invariant] + Nothing -> Just extended -- Not solved yet + Just alt -- We have a solution + | alt == nalt -> Nothing -- ... which is contradictory + | otherwise -> Just original -- ... which is compatible, rendering the + where -- refutation redundant + (y, e) = varDeepLookup pos (idName x) + extended = original { tm_neg = neg' } + neg' = alterDNameEnv (delNulls (insertNoDup nalt)) neg y --- | Initial state of the oracle. -initialTmState :: TmState -initialTmState = ([], (False, emptyNameEnv)) +-- | When updating 'tm_neg', we want to delete any 'null' entries. This adapter +-- intends to provide a suitable interface for 'alterDNameEnv'. +delNulls :: ([a] -> [a]) -> Maybe [a] -> Maybe [a] +delNulls f mb_entry + | ret@(_:_) <- f (fromMaybe [] mb_entry) = Just ret + | otherwise = Nothing --- | Solve a complex equality (top-level). -solveOneEq :: TmState -> ComplexEq -> Maybe TmState -solveOneEq solver_env@(_,(_,env)) complex - = solveComplexEq solver_env -- do the actual *merging* with existing state - $ simplifyComplexEq -- simplify as much as you can - $ applySubstComplexEq env complex -- replace everything we already know +-- | Return all 'PmAltCon' shapes that are impossible for 'Id' to take, i.e. +-- would immediately lead to a refutation by the term oracle. +lookupRefutableAltCons :: Id -> TmState -> [PmAltCon] +lookupRefutableAltCons x TmS { tm_neg = neg } + = fromMaybe [] (lookupDNameEnv neg (idName x)) --- | Solve a complex equality. --- Nothing => definitely unsatisfiable --- Just tms => I have added the complex equality and added --- it to the tmstate; the result may or may not be --- satisfiable -solveComplexEq :: TmState -> ComplexEq -> Maybe TmState -solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of +-- | Is the given variable /rigid/ (i.e., we have a solution for it) or +-- /flexible/ (i.e., no solution)? Returns the solution if /rigid/. A +-- semantically helpful alias for 'lookupNameEnv'. +isRigid :: TmState -> Name -> Maybe PmExpr +isRigid TmS{ tm_pos = pos } x = lookupNameEnv pos x + +-- | @isFlexible tms = isNothing . 'isRigid' tms@ +isFlexible :: TmState -> Name -> Bool +isFlexible tms = isNothing . isRigid tms + +-- | Try to unify two 'PmExpr's and record the gained knowledge in the +-- 'TmState'. +-- +-- Returns @Nothing@ when there's a contradiction. Returns @Just tms@ +-- when the constraint was compatible with prior facts, in which case @tms@ has +-- integrated the knowledge from the equality constraint. +unify :: TmState -> (PmExpr, PmExpr) -> Maybe TmState +unify tms eq@(e1, e2) = case eq of -- We cannot do a thing about these cases - (PmExprOther _,_) -> Just (standby, (True, env)) - (_,PmExprOther _) -> Just (standby, (True, env)) + (PmExprOther _,_) -> boring + (_,PmExprOther _) -> boring (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of -- See Note [Undecidable Equality for Overloaded Literals] - True -> Just solver_state - False -> Nothing + True -> boring + False -> unsat (PmExprCon c1 ts1, PmExprCon c2 ts2) - | c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2) - | otherwise -> Nothing - (PmExprCon _ [], PmExprEq t1 t2) - | isTruePmExpr e1 -> solveComplexEq solver_state (t1, t2) - | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env)) - (PmExprEq t1 t2, PmExprCon _ []) - | isTruePmExpr e2 -> solveComplexEq solver_state (t1, t2) - | isFalsePmExpr e2 -> Just (eq:standby, (unhandled, env)) + | c1 == c2 -> foldlM unify tms (zip ts1 ts2) + | otherwise -> unsat (PmExprVar x, PmExprVar y) - | x == y -> Just solver_state - | otherwise -> extendSubstAndSolve x e2 solver_state + | x == y -> boring - (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state - (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state + -- It's important to handle both rigid cases first, otherwise we get cyclic + -- substitutions. Cf. 'extendSubstAndSolve' and + -- @testsuite/tests/pmcheck/should_compile/CyclicSubst.hs@. + (PmExprVar x, _) + | Just e1' <- isRigid tms x -> unify tms (e1', e2) + (_, PmExprVar y) + | Just e2' <- isRigid tms y -> unify tms (e1, e2') + (PmExprVar x, PmExprVar y) -> Just (equate x y tms) + (PmExprVar x, _) -> trySolve x e2 tms + (_, PmExprVar y) -> trySolve y e1 tms - (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env)) + _ -> WARN( True, text "unify: Catch all" <+> ppr eq) + boring -- I HATE CATCH-ALLS + where + boring = Just tms + unsat = Nothing - _ -> WARN( True, text "solveComplexEq: Catch all" <+> ppr eq ) - Just (standby, (True, env)) -- I HATE CATCH-ALLS +-- | Merges the equivalence classes of @x@ and @y@ by extending the substitution +-- with @x :-> y@. +-- Preconditions: @x /= y@ and both @x@ and @y@ are flexible (cf. +-- 'isFlexible'/'isRigid'). +equate :: Name -> Name -> TmState -> TmState +equate x y tms@TmS{ tm_pos = pos, tm_neg = neg } + = ASSERT( x /= y ) + ASSERT( isFlexible tms x ) + ASSERT( isFlexible tms y ) + tms' + where + pos' = extendNameEnv pos x (PmExprVar y) + -- Be careful to uphold Note [The Pos/Neg invariant] by merging the refuts + -- of x into those of y + nalts = fromMaybe [] (lookupDNameEnv neg x) + neg' = alterDNameEnv (delNulls (unionLists nalts)) neg y + `delFromDNameEnv` x + tms' = TmS { tm_pos = pos', tm_neg = neg' } --- | Extend the substitution and solve the (possibly updated) constraints. -extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState -extendSubstAndSolve x e (standby, (unhandled, env)) - = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed) +-- | Extend the substitution with a mapping @x: -> e@ if compatible with +-- refutable shapes of @x@ and its solution, reject (@Nothing@) otherwise. +-- +-- Precondition: @x@ is flexible (cf. 'isFlexible'/'isRigid'). +-- Precondition: @e@ is a 'PmExprCon' or 'PmExprLit' +trySolve:: Name -> PmExpr -> TmState -> Maybe TmState +trySolve x e _tms@TmS{ tm_pos = pos, tm_neg = neg } + | ASSERT( isFlexible _tms x ) + ASSERT( _is_whnf e ) + isRefutable x e neg + = Nothing + | otherwise + = Just (TmS (extendNameEnv pos x e) (delFromDNameEnv neg x)) where - -- Apply the substitution to the worklist and partition them to the ones - -- that had some progress and the rest. Then, recurse over the ones that - -- had some progress. Careful about performance: - -- See Note [Representation of Term Equalities] in deSugar/Check.hs - (changed, unchanged) = partitionWith (substComplexEq x e) standby - new_incr_state = (unchanged, (unhandled, extendNameEnv env x e)) + _is_whnf PmExprCon{} = True + _is_whnf PmExprLit{} = True + _is_whnf _ = False -- | When we know that a variable is fresh, we do not actually have to -- check whether anything changes, we know that nothing does. Hence, --- `extendSubst` simply extends the substitution, unlike what --- `extendSubstAndSolve` does. +-- @extendSubst@ simply extends the substitution, unlike what +-- 'extendSubstAndSolve' does. extendSubst :: Id -> PmExpr -> TmState -> TmState -extendSubst y e (standby, (unhandled, env)) +extendSubst y e solver_state@TmS{ tm_pos = pos } | isNotPmExprOther simpl_e - = (standby, (unhandled, extendNameEnv env x simpl_e)) - | otherwise = (standby, (True, env)) + = solver_state { tm_pos = extendNameEnv pos x simpl_e } + | otherwise = solver_state where x = idName y - simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e - --- | Simplify a complex equality. -simplifyComplexEq :: ComplexEq -> ComplexEq -simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2) - --- | Simplify an expression. The boolean indicates if there has been any --- simplification or if the operation was a no-op. -simplifyPmExpr :: PmExpr -> (PmExpr, Bool) --- See Note [Deep equalities] -simplifyPmExpr e = case e of - PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of - (ts', bs) -> (PmExprCon c ts', or bs) - PmExprEq t1 t2 -> simplifyEqExpr t1 t2 - _other_expr -> (e, False) -- the others are terminals - --- | Simplify an equality expression. The equality is given in parts. -simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool) --- See Note [Deep equalities] -simplifyEqExpr e1 e2 = case (e1, e2) of - -- Varables - (PmExprVar x, PmExprVar y) - | x == y -> (truePmExpr, True) - - -- Literals - (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of - -- See Note [Undecidable Equality for Overloaded Literals] - True -> (truePmExpr, True) - False -> (falsePmExpr, True) - - -- Can potentially be simplified - (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of - ((e1', True ), (e2', _ )) -> simplifyEqExpr e1' e2' - ((e1', _ ), (e2', True )) -> simplifyEqExpr e1' e2' - ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress - (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of - ((e1', True ), (e2', _ )) -> simplifyEqExpr e1' e2' - ((e1', _ ), (e2', True )) -> simplifyEqExpr e1' e2' - ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress - - -- Constructors - (PmExprCon c1 ts1, PmExprCon c2 ts2) - | c1 == c2 -> - let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1 - (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2 - (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2' - worst_case = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2') - in if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress - | all isTruePmExpr tss -> (truePmExpr, True) - | any isFalsePmExpr tss -> (falsePmExpr, True) - | otherwise -> (worst_case, False) - | otherwise -> (falsePmExpr, True) - - -- We cannot do anything about the rest.. - _other_equality -> (original, False) - - where - original = PmExprEq e1 e2 -- reconstruct equality - --- | Apply an (un-flattened) substitution to a simple equality. -applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq -applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2) + simpl_e = exprDeepLookup pos e --- | Apply an (un-flattened) substitution to a variable. -varDeepLookup :: PmVarEnv -> Name -> PmExpr -varDeepLookup env x - | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper - | otherwise = PmExprVar x -- terminal +-- | Apply an (un-flattened) substitution to a variable and return its +-- representative in the triangular substitution @env@ and the completely +-- substituted expression. The latter may just be the representative wrapped +-- with 'PmExprVar' if we haven't found a solution for it yet. +varDeepLookup :: TmVarCtEnv -> Name -> (Name, PmExpr) +varDeepLookup env x = case lookupNameEnv env x of + Just (PmExprVar y) -> varDeepLookup env y + Just e -> (x, exprDeepLookup env e) -- go deeper + Nothing -> (x, PmExprVar x) -- terminal {-# INLINE varDeepLookup #-} -- | Apply an (un-flattened) substitution to an expression. -exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr -exprDeepLookup env (PmExprVar x) = varDeepLookup env x +exprDeepLookup :: TmVarCtEnv -> PmExpr -> PmExpr +exprDeepLookup env (PmExprVar x) = snd (varDeepLookup env x) exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es) -exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1) - (exprDeepLookup env e2) exprDeepLookup _ other_expr = other_expr -- PmExprLit, PmExprOther -- | External interface to the term oracle. -tmOracle :: TmState -> [ComplexEq] -> Maybe TmState +tmOracle :: TmState -> [TmVarCt] -> Maybe TmState tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs -- | Type of a PmLit @@ -248,18 +314,49 @@ pmLitType (PmSLit lit) = hsLitType lit pmLitType (PmOLit _ lit) = overLitType lit -{- Note [Deep equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving nested equalities is the most difficult part. The general strategy -is the following: +{- Note [Refutable shapes] +~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just - (e1 ~ e2) and then treated recursively. +Consider a pattern match like - * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless - we know more about the inner equality (e1 ~ e2). That's exactly what - `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns - truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note - that it is not e but rather e', since it may perform some - simplifications deeper. + foo x + | 0 <- x = 42 + | 0 <- x = 43 + | 1 <- x = 44 + | otherwise = 45 + +This will result in the following initial matching problem: + + PatVec: x (0 <- x) + ValVec: $tm_y + +Where the first line is the pattern vector and the second line is the value +vector abstraction. When we handle the first pattern guard in Check, it will be +desugared to a match of the form + + PatVec: x 0 + ValVec: $tm_y x + +In LitVar, this will split the value vector abstraction for `x` into a positive +`PmLit 0` and a negative `PmLit x [0]` value abstraction. While the former is +immediately matched against the pattern vector, the latter (vector value +abstraction `~[0] $tm_y`) is completely uncovered by the clause. + +`pmcheck` proceeds by *discarding* the the value vector abstraction involving +the guard to accomodate for the desugaring. But this also discards the valuable +information that `x` certainly is not the literal 0! Consequently, we wouldn't +be able to report the second clause as redundant. + +That's a typical example of why we need the term oracle, and in this specific +case, the ability to encode that `x` certainly is not the literal 0. Now the +term oracle can immediately refute the constraint `x ~ 0` generated by the +second clause and report the clause as redundant. After the third clause, the +set of such *refutable* literals is again extended to `[0, 1]`. + +In general, we want to store a set of refutable shapes (`PmAltCon`) for each +variable. That's the purpose of the `PmRefutEnv`. `addSolveRefutableAltCon` will +add such a refutable mapping to the `PmRefutEnv` in the term oracles state and +check if causes any immediate contradiction. Whenever we record a solution in +the substitution via `extendSubstAndSolve`, the refutable environment is checked +for any matching refutable `PmAltCon`. -} diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-} +{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- -- (c) The University of Glasgow 2002-2006 @@ -33,7 +33,7 @@ import SMRep import DynFlags import Outputable -import Platform +import GHC.Platform import Util import Unique import UniqDSet @@ -224,9 +224,7 @@ | AllocLabel Word16 (Assembler a) | Emit Word16 [Operand] (Assembler a) | NullAsm a - -instance Functor Assembler where - fmap = liftM + deriving (Functor) instance Applicative Assembler where pure = NullAsm diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fprof-auto-top #-} -- @@ -22,7 +23,7 @@ import BasicTypes import DynFlags import Outputable -import Platform +import GHC.Platform import Name import MkId import Id @@ -1861,7 +1862,7 @@ -- See Note [generating code for top-level string literal bindings]. } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) +newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) ioToBc :: IO a -> BcM a ioToBc io = BcM $ \st -> do @@ -1890,9 +1891,6 @@ returnBc :: a -> BcM a returnBc result = BcM $ \st -> (return (st, result)) - -instance Functor BcM where - fmap = liftM instance Applicative BcM where pure = returnBc diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs --- a/compiler/ghci/GHCi.hs +++ b/compiler/ghci/GHCi.hs @@ -51,7 +51,7 @@ import GhcPrelude import GHCi.Message -#if defined(GHCI) +#if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run #endif import GHCi.RemoteTypes @@ -157,7 +157,7 @@ * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs -} -#if !defined(GHCI) +#if !defined(HAVE_INTERNAL_INTERPRETER) needExtInt :: IO a needExtInt = throwIO (InstallationError "this operation requires -fexternal-interpreter") @@ -175,7 +175,7 @@ uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] iservCall iserv msg | otherwise = -- Just run it directly -#if defined(GHCI) +#if defined(HAVE_INTERNAL_INTERPRETER) run msg #else needExtInt @@ -391,7 +391,7 @@ writeIORef iservLookupSymbolCache $! addToUFM cache str p return (Just p) | otherwise = -#if defined(GHCI) +#if defined(HAVE_INTERNAL_INTERPRETER) fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #else needExtInt @@ -642,7 +642,7 @@ | gopt Opt_ExternalInterpreter dflags = throwIO (InstallationError "this operation requires -fno-external-interpreter") -#if defined(GHCI) +#if defined(HAVE_INTERNAL_INTERPRETER) | otherwise = localRef _r #else diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -50,7 +50,7 @@ import qualified Maybes import UniqDSet import FastString -import Platform +import GHC.Platform import SysTools import FileCleanup @@ -343,7 +343,7 @@ -- Add directories to library search paths, this only has an effect -- on Windows. On Unix OSes this function is a NOP. - let all_paths = let paths = takeDirectory (fst $ pgm_c dflags) + let all_paths = let paths = takeDirectory (pgm_c dflags) : framework_paths ++ lib_paths_base ++ [ takeDirectory dll | DLLPath dll <- libspecs ] @@ -352,8 +352,10 @@ all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + let merged_specs = mergeStaticObjects cmdline_lib_specs pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls - cmdline_lib_specs + merged_specs + maybePutStr dflags "final link ... " ok <- resolveObjs hsc_env @@ -365,6 +367,19 @@ return pls1 +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of +-- cyclic symbol references when dynamically linking. Specifically, we link +-- together all of the static objects into a single shared object, avoiding +-- the issue we saw in #13786. +mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] +mergeStaticObjects specs = go [] specs + where + go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] + go accum (Objects objs : rest) = go (objs ++ accum) rest + go accum@(_:_) rest = Objects (reverse accum) : go [] rest + go [] (spec:rest) = spec : go [] rest + go [] [] = [] + {- Note [preload packages] Why do we need to preload packages from the command line? This is an @@ -392,7 +407,7 @@ classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) classifyLdInput dflags f - | isObjectFilename platform f = return (Just (Object f)) + | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do putLogMsg dflags NoReason SevInfo noSrcSpan @@ -407,8 +422,8 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of - Object static_ish -> do - (b, pls1) <- preload_static lib_paths static_ish + Objects static_ishs -> do + (b, pls1) <- preload_statics lib_paths static_ishs maybePutStrLn dflags (if b then "done" else "not found") return pls1 @@ -467,13 +482,13 @@ intercalate "\n" (map (" "++) paths))) -- Not interested in the paths in the static case. - preload_static _paths name - = do b <- doesFileExist name + preload_statics _paths names + = do b <- or <$> mapM doesFileExist names if not b then return (False, pls) else if dynamicGhc - then do pls1 <- dynLoadObjs hsc_env pls [name] + then do pls1 <- dynLoadObjs hsc_env pls names return (True, pls1) - else do loadObj hsc_env name + else do mapM_ (loadObj hsc_env) names return (True, pls) preload_static_archive _paths name @@ -1123,7 +1138,10 @@ -- We don't do any cleanup when linking objects with the -- dynamic linker. Doing so introduces extra complexity for -- not much benefit. - | otherwise + + -- Code unloading currently disabled due to instability. + -- See #16841. + | False -- otherwise = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] -- The components of a BCO linkable may contain -- dot-o files. Which is very confusing. @@ -1131,6 +1149,7 @@ -- But the BCO parts can be unlinked just by -- letting go of them (plus of course depopulating -- the symbol table which is done in the main body) + | otherwise = return () -- see #16841 {- ********************************************************************** @@ -1139,7 +1158,9 @@ ********************************************************************* -} data LibrarySpec - = Object FilePath -- Full path name of a .o file, including trailing .o + = Objects [FilePath] -- Full path names of set of .o files, including trailing .o + -- We allow batched loading to ensure that cyclic symbol + -- references can be resolved (see #13786). -- For dynamic objects only, try to find the object -- file in all the directories specified in -- v_Library_paths before giving up. @@ -1173,7 +1194,7 @@ ["base", "template-haskell", "editline"] showLS :: LibrarySpec -> String -showLS (Object nm) = "(static) " ++ nm +showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" showLS (Archive nm) = "(static archive) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm @@ -1270,7 +1291,8 @@ -- Complication: all the .so's must be loaded before any of the .o's. let known_dlls = [ dll | DLLPath dll <- classifieds ] dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] + objs = [ obj | Objects objs <- classifieds + , obj <- objs ] archs = [ arch | Archive arch <- classifieds ] -- Add directories to library search paths @@ -1478,8 +1500,8 @@ (ArchX86_64, OSSolaris2) -> "64" so_name _ -> so_name - findObject = liftM (fmap Object) $ findFile dirs obj_file - findDynObject = liftM (fmap Object) $ findFile dirs dyn_obj_file + findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file + findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file findArchive = let local name = liftM (fmap Archive) $ findFile dirs name in apply (map local arch_files) findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs --- a/compiler/hieFile/HieBin.hs +++ b/compiler/hieFile/HieBin.hs @@ -4,6 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where +import GHC.Settings ( maybeRead ) + import Config ( cProjectVersion ) import GhcPrelude import Binary @@ -17,7 +19,6 @@ import PrelInfo import SrcLoc import UniqSupply ( takeUniqFromSupply ) -import Util ( maybeRead ) import Unique import UniqFM diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -6,6 +6,7 @@ This module converts Template Haskell syntax into HsSyn -} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -40,7 +41,7 @@ import MonadUtils ( foldrM ) import qualified Data.ByteString as BS -import Control.Monad( unless, liftM, ap ) +import Control.Monad( unless, ap ) import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) @@ -71,6 +72,7 @@ ------------------------------------------------------------------- newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } + deriving (Functor) -- Push down the source location; -- Can fail, with a single error message @@ -83,9 +85,6 @@ -- In particular, we want it on binding locations, so that variables bound in -- the spliced-in declarations get a location that at least relates to the splice point -instance Functor CvtM where - fmap = liftM - instance Applicative CvtM where pure x = CvtM $ \loc -> Right (loc,x) (<*>) = ap @@ -892,17 +891,11 @@ ; return $ HsLamCase noExt (mkMatchGroup FromSource ms') } - cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' } + cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExt e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) - cvt (TupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple noExt - (map (noLoc . (Present noExt)) es') - Boxed } - cvt (UnboxedTupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple noExt - (map (noLoc . (Present noExt)) es') - Unboxed } + cvt (TupE es) = cvt_tup es Boxed + cvt (UnboxedTupE es) = cvt_tup es Unboxed cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity ; return $ ExplicitSum noExt @@ -1013,6 +1006,15 @@ cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } + +cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) +cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg + cvtl_maybe (Just e) = fmap (Present noExt) (cvtl e) + ; es' <- mapM cvtl_maybe es + ; return $ ExplicitTuple + noExt + (map noLoc es') + boxity } {- Note [Operator assocation] We must be quite careful about adding parens: diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -42,7 +42,7 @@ import Unique import Outputable import NameCache -import Platform +import GHC.Platform import FastString import Constants import Util diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -3,7 +3,7 @@ -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. -- -module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where +module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} -- ---------------------------------------------------------------------------- -- | Base LLVM Code Generation module @@ -12,7 +13,7 @@ LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion, supportedLlvmVersion, llvmVersionStr, + LlvmVersion (..), supportedLlvmVersion, llvmVersionStr, LlvmM, runLlvm, liftStream, withClearVars, varLookup, varInsert, @@ -48,7 +49,7 @@ import FastString import Cmm hiding ( succ ) import Outputable as Outp -import Platform +import GHC.Platform import UniqFM import Unique import BufWrite ( BufHandle ) @@ -151,12 +152,12 @@ where platform = targetPlatform dflags isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE (YmmReg _) = True - isSSE (ZmmReg _) = True - isSSE _ = False + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _ _ _ _ ) = True + isSSE (YmmReg _ _ _ _ ) = True + isSSE (ZmmReg _ _ _ _ ) = True + isSSE _ = False -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] @@ -176,14 +177,25 @@ -- -- | LLVM Version Number -type LlvmVersion = (Int, Int) +data LlvmVersion + = LlvmVersion Int + | LlvmVersionOld Int Int + deriving Eq +-- Custom show instance for backwards compatibility. +instance Show LlvmVersion where + show (LlvmVersion maj) = show maj + show (LlvmVersionOld maj min) = show maj ++ "." ++ show min + -- | The LLVM Version that is currently supported. supportedLlvmVersion :: LlvmVersion -supportedLlvmVersion = sUPPORTED_LLVM_VERSION +supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION llvmVersionStr :: LlvmVersion -> String -llvmVersionStr (major, minor) = show major ++ "." ++ show minor +llvmVersionStr v = + case v of + LlvmVersion maj -> show maj + LlvmVersionOld maj min -> show maj ++ "." ++ show min -- ---------------------------------------------------------------------------- -- * Environment Handling @@ -209,10 +221,7 @@ -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } - -instance Functor LlvmM where - fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env - return (f x, env') + deriving (Functor) instance Applicative LlvmM where pure x = LlvmM $ \env -> return (x, env) diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,7 +29,7 @@ import ForeignCall import Outputable hiding (panic, pprPanic) import qualified Outputable -import Platform +import GHC.Platform import OrdList import UniqSupply import Unique @@ -169,17 +169,25 @@ let s = Fence False SyncSeqCst return (unitOL s, []) +-- | Insert a 'barrier', unless the target platform is in the provided list of +-- exceptions (where no code will be emitted instead). +barrierUnless :: [Arch] -> LlvmM StmtData +barrierUnless exs = do + platform <- getLlvmPlatform + if platformArch platform `elem` exs + then return (nilOL, []) + else barrier + -- | Foreign Calls genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData --- Write barrier needs to be handled specially as it is implemented as an LLVM --- intrinsic function. +-- Barriers need to be handled specially as they are implemented as LLVM +-- intrinsic functions. +genCall (PrimTarget MO_ReadBarrier) _ _ = + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] genCall (PrimTarget MO_WriteBarrier) _ _ = do - platform <- getLlvmPlatform - if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] - then return (nilOL, []) - else barrier + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] genCall (PrimTarget MO_Touch) _ _ = return (nilOL, []) @@ -745,7 +753,9 @@ return $ case mop of MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" MO_F32_Fabs -> fsLit "llvm.fabs.f32" MO_F32_Pwr -> fsLit "llvm.pow.f32" @@ -767,7 +777,9 @@ MO_F32_Atanh -> fsLit "atanhf" MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" MO_F64_Fabs -> fsLit "llvm.fabs.f64" MO_F64_Pwr -> fsLit "llvm.pow.f64" @@ -827,6 +839,7 @@ -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the -- appropriate case of genCall. MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported MO_UF_Conv _ -> unsupported @@ -1274,6 +1287,7 @@ MO_VU_Quot _ _ -> panicOp MO_VU_Rem _ _ -> panicOp + MO_VF_Broadcast _ _ -> panicOp MO_VF_Insert _ _ -> panicOp MO_VF_Extract _ _ -> panicOp @@ -1470,6 +1484,7 @@ MO_VS_Neg {} -> panicOp + MO_VF_Broadcast {} -> panicOp MO_VF_Insert {} -> panicOp MO_VF_Extract {} -> panicOp @@ -1831,9 +1846,9 @@ let liveRegs = alwaysLive ++ live isSSE (FloatReg _) = True isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE (YmmReg _) = True - isSSE (ZmmReg _) = True + isSSE (XmmReg _ _ _ _) = True + isSSE (YmmReg _ _ _ _) = True + isSSE (ZmmReg _ _ _ _) = True isSSE _ = False -- Set to value or "undef" depending on whether the register is diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -18,7 +18,7 @@ import CLabel import Cmm import DynFlags -import Platform +import GHC.Platform import FastString import Outputable diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -60,24 +60,24 @@ DoubleReg 4 -> doubleGlobal $ "D4" ++ suf DoubleReg 5 -> doubleGlobal $ "D5" ++ suf DoubleReg 6 -> doubleGlobal $ "D6" ++ suf - XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf - XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf - XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf - XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf - XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf - XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf - YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf - YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf - YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf - YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf - YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf - YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf - ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf - ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf - ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf - ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf - ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf - ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf + XmmReg 1 _ _ _ -> xmmGlobal $ "XMM1" ++ suf + XmmReg 2 _ _ _ -> xmmGlobal $ "XMM2" ++ suf + XmmReg 3 _ _ _ -> xmmGlobal $ "XMM3" ++ suf + XmmReg 4 _ _ _ -> xmmGlobal $ "XMM4" ++ suf + XmmReg 5 _ _ _ -> xmmGlobal $ "XMM5" ++ suf + XmmReg 6 _ _ _ -> xmmGlobal $ "XMM6" ++ suf + YmmReg 1 _ _ _ -> ymmGlobal $ "YMM1" ++ suf + YmmReg 2 _ _ _ -> ymmGlobal $ "YMM2" ++ suf + YmmReg 3 _ _ _ -> ymmGlobal $ "YMM3" ++ suf + YmmReg 4 _ _ _ -> ymmGlobal $ "YMM4" ++ suf + YmmReg 5 _ _ _ -> ymmGlobal $ "YMM5" ++ suf + YmmReg 6 _ _ _ -> ymmGlobal $ "YMM6" ++ suf + ZmmReg 1 _ _ _ -> zmmGlobal $ "ZMM1" ++ suf + ZmmReg 2 _ _ _ -> zmmGlobal $ "ZMM2" ++ suf + ZmmReg 3 _ _ _ -> zmmGlobal $ "ZMM3" ++ suf + ZmmReg 4 _ _ _ -> zmmGlobal $ "ZMM4" ++ suf + ZmmReg 5 _ _ _ -> zmmGlobal $ "ZMM5" ++ suf + ZmmReg 6 _ _ _ -> zmmGlobal $ "ZMM6" ++ suf MachSp -> wordGlobal $ "MachSp" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -14,7 +14,7 @@ import GhcPrelude import DynFlags ( DynFlags, targetPlatform ) -import Platform ( platformArch, Arch(..) ) +import GHC.Platform ( platformArch, Arch(..) ) import ErrUtils ( withTiming ) import Outputable ( text ) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -56,9 +56,9 @@ import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc -import LlvmCodeGen ( llvmFixupAsm ) +import LlvmCodeGen ( LlvmVersion (..), llvmFixupAsm ) import MonadUtils -import Platform +import GHC.Platform import TcRnTypes import ToolSettings import Hooks @@ -1190,9 +1190,6 @@ ----------------------------------------------------------------------------- -- Cc phase --- we don't support preprocessing .c files (with -E) now. Doing so introduces --- way too many hacks, and I can't say I've ever used it anyway. - runPhase (RealPhase cc_phase) input_fn dflags | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] = do @@ -1214,6 +1211,16 @@ (includePathsQuote cmdline_include_paths) let include_paths = include_paths_quote ++ include_paths_global + -- pass -D or -optP to preprocessor when compiling foreign C files + -- (#16737). Doing it in this way is simpler and also enable the C + -- compiler to performs preprocessing and parsing in a single pass, + -- but it may introduce inconsistency if a different pgm_P is specified. + let more_preprocessor_opts = concat + [ ["-Xpreprocessor", i] + | not hcc + , i <- getOpts dflags opt_P + ] + let gcc_extra_viac_flags = extraGccViaCFlags dflags let pic_c_flags = picCCOpts dflags @@ -1223,7 +1230,7 @@ -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. pkg_extra_cc_opts <- liftIO $ - if cc_phase `eqPhase` HCc + if hcc then return [] else getPackageExtraCcOpts dflags pkgs @@ -1305,6 +1312,7 @@ ++ [ "-include", ghcVersionH ] ++ framework_paths ++ include_paths + ++ more_preprocessor_opts ++ pkg_extra_cc_opts )) @@ -2030,7 +2038,8 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags return $ case llvmVer of - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] + Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] + Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] _ -> [] where format (major, minor) diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -3,7 +3,7 @@ -- | Dynamically lookup up values from modules and loading them. module DynamicLoading ( initializePlugins, -#if defined(GHCI) +#if defined(HAVE_INTERPRETER) -- * Loading plugins loadFrontendPlugin, @@ -27,7 +27,7 @@ import GhcPrelude import DynFlags -#if defined(GHCI) +#if defined(HAVE_INTERPRETER) import Linker ( linkModule, getHValue ) import GHCi ( wormhole ) import SrcLoc ( noSrcSpan ) @@ -76,7 +76,7 @@ -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes. initializePlugins :: HscEnv -> DynFlags -> IO DynFlags -#if !defined(GHCI) +#if !defined(HAVE_INTERPRETER) initializePlugins _ df = do let pluginMods = pluginModNames df unless (null pluginMods) (pluginError pluginMods) @@ -96,7 +96,7 @@ #endif -#if defined(GHCI) +#if defined(HAVE_INTERPRETER) loadPlugins :: HscEnv -> IO [LoadedPlugin] loadPlugins hsc_env diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -219,6 +219,8 @@ Kind, PredType, ThetaType, pprForAll, pprThetaArrowTy, + parseInstanceHead, + getInstancesForType, -- ** Entities TyThing(..), @@ -336,7 +338,7 @@ import Annotations import Module import Panic -import Platform +import GHC.Platform import Bag ( listToBag ) import ErrUtils import MonadUtils diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -267,7 +267,75 @@ load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = do mod_graph <- depanal [] False - load' how_much (Just batchMsg) mod_graph + success <- load' how_much (Just batchMsg) mod_graph + warnUnusedPackages + pure success + +-- Note [Unused packages] +-- +-- Cabal passes `--package-id` flag for each direct dependency. But GHC +-- loads them lazily, so when compilation is done, we have a list of all +-- actually loaded packages. All the packages, specified on command line, +-- but never loaded, are probably unused dependencies. + +warnUnusedPackages :: GhcMonad m => m () +warnUnusedPackages = do + hsc_env <- getSession + eps <- liftIO $ hscEPS hsc_env + + let dflags = hsc_dflags hsc_env + pit = eps_PIT eps + + let loadedPackages + = map (getPackageDetails dflags) + . nub . sort + . map moduleUnitId + . moduleEnvKeys + $ pit + + requestedArgs = mapMaybe packageArg (packageFlags dflags) + + unusedArgs + = filter (\arg -> not $ any (matching dflags arg) loadedPackages) + requestedArgs + + let warn = makeIntoWarning + (Reason Opt_WarnUnusedPackages) + (mkPlainErrMsg dflags noSrcSpan msg) + msg = vcat [ text "The following packages were specified" <+> + text "via -package or -package-id flags," + , text "but were not needed for compilation:" + , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] + + when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $ + logWarnings (listToBag [warn]) + + where + packageArg (ExposePackage _ arg _) = Just arg + packageArg _ = Nothing + + pprUnusedArg (PackageArg str) = text str + pprUnusedArg (UnitIdArg uid) = ppr uid + + withDash = (<+>) (text "-") + + matchingStr :: String -> PackageConfig -> Bool + matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + + matching :: DynFlags -> PackageArg -> PackageConfig -> Bool + matching _ (PackageArg str) p = matchingStr str p + matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p + + -- For wired-in packages, we have to unwire their id, + -- otherwise they won't match package flags + realUnitId :: DynFlags -> PackageConfig -> UnitId + realUnitId dflags + = unwireUnitId dflags + . DefiniteUnitId + . DefUnitId + . installedPackageConfigId -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -67,6 +67,7 @@ , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType , hscParseExpr + , hscParseType , hscCompileCoreExpr -- * Low-level exports for hooks , hscCompileCoreExpr' @@ -113,6 +114,7 @@ import TcRnDriver import TcIface ( typecheckIface ) import TcRnMonad +import TcHsSyn ( ZonkFlexi (DefaultFlexi) ) import NameCache ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo @@ -147,7 +149,7 @@ import DynFlags import ErrUtils -import Platform ( platformOS, osSubsectionsViaSymbols ) +import GHC.Platform ( platformOS, osSubsectionsViaSymbols ) import Outputable import NameEnv @@ -496,6 +498,14 @@ hsc_env <- getHscEnv dflags <- getDynFlags + -- -Wmissing-safe-haskell-mode + when (not (safeHaskellModeEnabled dflags) + && wopt Opt_WarnMissingSafeHaskellMode dflags) $ + logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ + mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ + warnMissingSafeHaskellMode + tcg_res <- {-# SCC "Typecheck-Rename" #-} ioMsgMaybe $ tcRnModule hsc_env sum @@ -518,7 +528,9 @@ safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') when safe $ do case wopt Opt_WarnSafe dflags of - True -> (logWarnings $ unitBag $ + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnSafe) $ mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res') @@ -540,6 +552,8 @@ errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" errTwthySafe t = quotes (pprMod t) <+> text "is marked as Trustworthy but has been inferred as safe!" + warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum)) + <+> text "is missing Safe Haskell mode" -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts @@ -1105,21 +1119,36 @@ let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] + safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted dflags trust trust_own_pkg m -- pkg trust reqs pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' + -- warn if Safe module imports Safe-Inferred module. + warns = if wopt Opt_WarnInferredSafeImports dflags + && safeLanguageOn dflags + && trust == Sf_SafeInferred + then inferredImportWarn + else emptyBag -- General errors we throw but Safe errors we log errs = case (safeM, safeP) of (True, True ) -> emptyBag (True, False) -> pkgTrustErr (False, _ ) -> modTrustErr in do + logWarnings warns logWarnings errs return (trust == Sf_Trustworthy, pkgRs) where + inferredImportWarn = unitBag + $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) + $ mkErrMsg dflags l (pkgQual dflags) + $ sep + [ text "Importing Safe-Inferred module " + <> ppr (moduleName m) + <> text " from explicitly Safe module" + ] pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" @@ -1142,6 +1171,7 @@ packageTrusted dflags _ _ _ | not (packageTrustOn dflags) = True packageTrusted _ Sf_Safe False _ = True + packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m | isHomePkg dflags m = True | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) @@ -1761,7 +1791,7 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env normalise ty + ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -30,6 +30,8 @@ exprType, typeKind, parseName, + parseInstanceHead, + getInstancesForType, getDocs, GetDocsFailure(..), showModule, @@ -102,6 +104,19 @@ import Data.Array import Exception +import TcRnDriver ( runTcInteractive, tcRnType ) +import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) + +import TcEnv (tcGetInstEnvs) + +import Inst (instDFunType) +import TcSimplify (solveWanteds) +import TcRnMonad +import TcEvidence +import Data.Bifunctor (second) + +import TcSMonad (runTcS) + -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -936,6 +951,161 @@ typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) typeKind normalise str = withSession $ \hsc_env -> do liftIO $ hscKcType hsc_env normalise str + +-- ---------------------------------------------------------------------------- +-- Getting the class instances for a type + +{- + Note [Querying instances for a type] + + Here is the implementation of GHC proposal 41. + (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) + + The objective is to take a query string representing a (partial) type, and + report all the class single-parameter class instances available to that type. + Extending this feature to multi-parameter typeclasses is left as future work. + + The general outline of how we solve this is: + + 1. Parse the type, leaving skolems in the place of type-holes. + 2. For every class, get a list of all instances that match with the query type. + 3. For every matching instance, ask GHC for the context the instance dictionary needs. + 4. Format and present the results, substituting our query into the instance + and simplifying the context. + + For example, given the query "Maybe Int", we want to return: + + instance Show (Maybe Int) + instance Read (Maybe Int) + instance Eq (Maybe Int) + .... + + [Holes in queries] + + Often times we want to know what instances are available for a polymorphic type, + like `Maybe a`, and we'd like to return instances such as: + + instance Show a => Show (Maybe a) + .... + + These queries are expressed using type holes, so instead of `Maybe a` the user writes + `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes + with (un-named) type variables. + + When zonking the type holes we have two real choices: replace them with Any or replace + them with skolem typevars. Using skolem type variables ensures that the output is more + intuitive to end users, and there is no difference in the results between Any and skolems. + +-} + +-- Find all instances that match a provided type +getInstancesForType :: GhcMonad m => Type -> m [ClsInst] +getInstancesForType ty = withSession $ \hsc_env -> do + liftIO $ runInteractiveHsc hsc_env $ do + ioMsgMaybe $ runTcInteractive hsc_env $ do + matches <- findMatchingInstances ty + fmap catMaybes . forM matches $ uncurry checkForExistence + +-- Parse a type string and turn any holes into skolems +parseInstanceHead :: GhcMonad m => String -> m Type +parseInstanceHead str = withSession $ \hsc_env0 -> do + (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty + + return ty + +-- Get all the constraints required of a dictionary binding +getDictionaryBindings :: PredType -> TcM WantedConstraints +getDictionaryBindings theta = do + dictName <- newName (mkDictOcc (mkVarOcc "magic")) + let dict_var = mkVanillaGlobal dictName theta + loc <- getCtLocM (GivenOrigin UnkSkol) Nothing + let wCs = mkSimpleWC [CtDerived + { ctev_pred = varType dict_var + , ctev_loc = loc + }] + + return wCs + +{- + When we've found an instance that a query matches against, we still need to + check that all the instance's constraints are satisfiable. checkForExistence + creates an instance dictionary and verifies that any unsolved constraints + mention a type-hole, meaning it is blocked on an unknown. + + If the instance satisfies this condition, then we return it with the query + substituted into the instance and all constraints simplified, for example given: + + instance D a => C (MyType a b) where + + and the query `MyType _ String` + + the unsolved constraints will be [D _] so we apply the substitution: + + { a -> _; b -> String} + + and return the instance: + + instance D _ => C (MyType _ String) + +-} + +checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) +checkForExistence res mb_inst_tys = do + (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys + + wanteds <- forM thetas getDictionaryBindings + (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds)) + + let all_residual_constraints = bagToList $ wc_simple residuals + let preds = map ctPred all_residual_constraints + if all isSatisfiablePred preds && (null $ wc_impl residuals) + then return . Just $ substInstArgs tys preds res + else return Nothing + + where + + -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least + -- one argument or for the head to be a TyVar. The reason is that we want to ensure + -- that all residual constraints mention a type-hole somewhere in the constraint, + -- meaning that with the correct choice of a concrete type it could be possible for + -- the constraint to be discharged. + isSatisfiablePred :: PredType -> Bool + isSatisfiablePred ty = case getClassPredTys_maybe ty of + Just (_, tys@(_:_)) -> all isTyVarTy tys + _ -> isTyVarTy ty + + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res))) + + {- Create a ClsInst with instantiated arguments and constraints. + + The thetas are the list of constraints that couldn't be solved because + they mention a type-hole. + -} + substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst + substInstArgs tys thetas inst = let + subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys) + -- Build instance head with arguments substituted in + tau = mkClassPred cls (substTheta subst args) + -- Constrain the instance with any residual constraints + phi = mkPhiTy thetas tau + sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi + + in inst { is_dfun = (is_dfun inst) { varType = sigma }} + where + (dfun_tvs, _, cls, args) = instanceSig inst + +-- Find instances where the head unifies with the provided type +findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] +findMatchingInstances ty = do + ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs + let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local + + concat <$> mapM (\cls -> do + let (matches, _, _) = lookupInstEnv True ies cls [ty] + return matches) allClasses ----------------------------------------------------------------------------- -- Compile an expression, run it, and deliver the result diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -135,7 +135,7 @@ import Module import Name import Outputable -import Platform +import GHC.Platform import PrelNames import TcEnv (lookupGlobal) import Type diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -40,17 +40,19 @@ import GhcPrelude +import GHC.Settings + import Module import Packages import Config import Outputable import ErrUtils -import Platform -import Util +import GHC.Platform import DynFlags import Fingerprint import ToolSettings +import qualified Data.Map as Map import System.FilePath import System.IO import System.Directory @@ -151,41 +153,29 @@ settingsStr <- readFile settingsFile platformConstantsStr <- readFile platformConstantsFile - mySettings <- case maybeReadFuzzy settingsStr of + settingsList <- case maybeReadFuzzy settingsStr of Just s -> return s Nothing -> pgmError ("Can't parse " ++ show settingsFile) + let mySettings = Map.fromList settingsList platformConstants <- case maybeReadFuzzy platformConstantsStr of Just s -> return s Nothing -> pgmError ("Can't parse " ++ show platformConstantsFile) - let getSetting key = case lookup key mySettings of - Just xs -> return $ expandTopDir top_dir xs - Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + -- See Note [Settings file] for a little more about this file. We're + -- just partially applying those functions and throwing 'Left's; they're + -- written in a very portable style to keep ghc-boot light. + let getSetting key = either pgmError pure $ + getFilePathSetting0 top_dir settingsFile mySettings key + getToolSetting :: String -> IO String getToolSetting key = expandToolDir mtool_dir <$> getSetting key - getBooleanSetting key = case lookup key mySettings of - Just "YES" -> return True - Just "NO" -> return False - Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs) - Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) - readSetting key = case lookup key mySettings of - Just xs -> - case maybeRead xs of - Just v -> return v - Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs) - Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) - crossCompiling <- getBooleanSetting "cross compiling" + getBooleanSetting :: String -> IO Bool + getBooleanSetting key = either pgmError pure $ + getBooleanSetting0 settingsFile mySettings key targetPlatformString <- getSetting "target platform string" - targetArch <- readSetting "target arch" - targetOS <- readSetting "target os" - targetWordSize <- readSetting "target word size" - targetUnregisterised <- getBooleanSetting "Unregisterised" - targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack" - targetHasIdentDirective <- readSetting "target has .ident directive" - targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols" tablesNextToCode <- getBooleanSetting "Tables next to code" myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, @@ -194,17 +184,21 @@ -- It would perhaps be nice to be able to override this -- with the settings file, but it would be a little fiddly -- to make that possible, so for now you can't. - gcc_prog <- getToolSetting "C compiler command" - gcc_args_str <- getSetting "C compiler flags" + cc_prog <- getToolSetting "C compiler command" + cc_args_str <- getSetting "C compiler flags" + cxx_args_str <- getSetting "C++ compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" cpp_prog <- getToolSetting "Haskell CPP command" cpp_args_str <- getSetting "Haskell CPP flags" - let unreg_gcc_args = if targetUnregisterised - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - cpp_args= map Option (words cpp_args_str) - gcc_args = map Option (words gcc_args_str - ++ unreg_gcc_args) + + platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings + + let unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cpp_args = map Option (words cpp_args_str) + cc_args = words cc_args_str ++ unreg_cc_args + cxx_args = words cxx_args_str ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsBuildId <- getBooleanSetting "ld supports build-id" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" @@ -236,11 +230,11 @@ -- Other things being equal, as and ld are simply gcc - gcc_link_args_str <- getSetting "C compiler link flags" - let as_prog = gcc_prog - as_args = gcc_args - ld_prog = gcc_prog - ld_args = gcc_args ++ map Option (words gcc_link_args_str) + cc_link_args_str <- getSetting "C compiler link flags" + let as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_prog + ld_args = map Option (cc_args ++ words cc_link_args_str) -- We just assume on command line lc_prog <- getSetting "LLVM llc command" @@ -249,17 +243,6 @@ let iserv_prog = libexec "ghc-iserv" - let platform = Platform { - platformArch = targetArch, - platformOS = targetOS, - platformWordSize = targetWordSize, - platformUnregisterised = targetUnregisterised, - platformHasGnuNonexecStack = targetHasGnuNonexecStack, - platformHasIdentDirective = targetHasIdentDirective, - platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols, - platformIsCrossCompiling = crossCompiling - } - integerLibrary <- getSetting "integer library" integerLibraryType <- case integerLibrary of "integer-gmp" -> pure IntegerGMP @@ -308,7 +291,7 @@ , toolSettings_pgm_L = unlit_path , toolSettings_pgm_P = (cpp_prog, cpp_args) , toolSettings_pgm_F = "" - , toolSettings_pgm_c = (gcc_prog, gcc_args) + , toolSettings_pgm_c = cc_prog , toolSettings_pgm_a = (as_prog, as_args) , toolSettings_pgm_l = (ld_prog, ld_args) , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) @@ -325,8 +308,8 @@ , toolSettings_opt_P = [] , toolSettings_opt_P_fingerprint = fingerprint0 , toolSettings_opt_F = [] - , toolSettings_opt_c = [] - , toolSettings_opt_cxx = [] + , toolSettings_opt_c = cc_args + , toolSettings_opt_cxx = cxx_args , toolSettings_opt_a = [] , toolSettings_opt_l = [] , toolSettings_opt_windres = [] @@ -357,7 +340,7 @@ , sPlatformConstants = platformConstants - , sRawSettings = mySettings + , sRawSettings = settingsList } diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs --- a/compiler/main/SysTools/ExtraObj.hs +++ b/compiler/main/SysTools/ExtraObj.hs @@ -17,7 +17,7 @@ import ErrUtils import DynFlags import Packages -import Platform +import GHC.Platform import Outputable import SrcLoc ( noSrcSpan ) import Module diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs --- a/compiler/main/SysTools/Info.hs +++ b/compiler/main/SysTools/Info.hs @@ -19,7 +19,7 @@ import System.IO -import Platform +import GHC.Platform import GhcPrelude import SysTools.Process @@ -219,7 +219,7 @@ -- See Note [Run-time linker info]. getCompilerInfo' :: DynFlags -> IO CompilerInfo getCompilerInfo' dflags = do - let (pgm,_) = pgm_c dflags + let pgm = pgm_c dflags -- Try to grab the info from the process output. parseCompilerInfo _stdo stde _exitc -- Regular GCC diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -13,7 +13,7 @@ import HscTypes import DynFlags import Outputable -import Platform +import GHC.Platform import Util import Data.Char @@ -23,7 +23,7 @@ import System.Process import GhcPrelude -import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion) +import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion) import SysTools.Process import SysTools.Info @@ -62,9 +62,9 @@ -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () runCc mLanguage dflags args = do - let (p,args0) = pgm_c dflags + let p = pgm_c dflags args1 = map Option userOpts - args2 = args0 ++ languageOptions ++ args ++ args1 + args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 @@ -126,12 +126,16 @@ -- -x c option. (languageOptions, userOpts) = case mLanguage of Nothing -> ([], userOpts_c) - Just language -> ([Option "-x", Option languageName], opts) where - (languageName, opts) = case language of - LangCxx -> ("c++", userOpts_cxx) - LangObjc -> ("objective-c", userOpts_c) - LangObjcxx -> ("objective-c++", userOpts_cxx) - _ -> ("c", userOpts_c) + Just language -> ([Option "-x", Option languageName], opts) + where + s = settings dflags + (languageName, opts) = case language of + LangC -> ("c", sOpt_c s ++ userOpts_c) + LangCxx -> ("c++", sOpt_cxx s ++ userOpts_cxx) + LangObjc -> ("objective-c", userOpts_c) + LangObjcxx -> ("objective-c++", userOpts_cxx) + LangAsm -> ("assembler", []) + RawObject -> ("c", []) -- claim C for lack of a better idea userOpts_c = getOpts dflags opt_c userOpts_cxx = getOpts dflags opt_cxx @@ -196,7 +200,7 @@ ) -- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int)) +figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) figureLlvmVersion dflags = do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) @@ -218,8 +222,10 @@ vline <- dropWhile (not . isDigit) `fmap` hGetLine pout v <- case span (/= '.') vline of ("",_) -> fail "no digits!" - (x,y) -> return (read x - , read $ takeWhile isDigit $ drop 1 y) + (x,"") -> return $ LlvmVersion (read x) + (x,y) -> return $ LlvmVersionOld + (read x) + (read $ takeWhile isDigit $ drop 1 y) hClose pin hClose pout @@ -333,7 +339,8 @@ runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = do - let (gcc, gcc_args) = pgm_c dflags + let cc = pgm_c dflags + cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags opts = map Option (getOpts dflags opt_windres) quote x = "\"" ++ x ++ "\"" @@ -341,8 +348,7 @@ -- spaces then windres fails to run gcc. We therefore need -- to tell it what command to use... Option ("--preprocessor=" ++ - unwords (map quote (gcc : - map showOpt gcc_args ++ + unwords (map quote (cc : map showOpt opts ++ ["-E", "-xc", "-DRC_INVOKED"]))) -- ...but if we do that then if windres calls popen then @@ -351,7 +357,7 @@ -- See #1828. : Option "--use-temp-file" : args - mb_env <- getGccEnv gcc_args + mb_env <- getGccEnv cc_args runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env touch :: DynFlags -> String -> String -> IO () diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -4,10 +4,10 @@ \section{Tidying up Core} -} -{-# LANGUAGE CPP, ViewPatterns #-} +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-} module TidyPgm ( - mkBootModDetailsTc, tidyProgram, globaliseAndTidyId + mkBootModDetailsTc, tidyProgram ) where #include "HsVersions.h" @@ -39,13 +39,11 @@ import MkId ( mkDictSelRhs ) import IdInfo import InstEnv -import FamInstEnv import Type ( tidyTopType ) import Demand ( appIsBottom, isTopSig, isBottomingSig ) import BasicTypes import Name hiding (varName) import NameSet -import NameEnv import NameCache import Avail import IfaceEnv @@ -60,6 +58,7 @@ import Maybes import UniqSupply import Outputable +import Util( filterOut ) import qualified ErrUtils as Err import Control.Monad @@ -149,65 +148,78 @@ Err.withTiming (pure dflags) (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ - do { let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts - ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns - ; type_env1 = mkBootTypeEnv (availsToNameSet exports) - (typeEnvIds type_env) tcs fam_insts - ; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 - ; dfun_ids = map instanceDFunId insts' - ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids - } - ; return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports - , md_complete_sigs = complete_sigs - }) - } + return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_complete_sigs = complete_sigs + }) where dflags = hsc_dflags hsc_env -mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv -mkBootTypeEnv exports ids tcs fam_insts - = tidyTypeEnv True $ - typeEnvFromEntities final_ids tcs fam_insts - where - -- Find the LocalIds in the type env that are exported - -- Make them into GlobalIds, and tidy their types - -- - -- It's very important to remove the non-exported ones - -- because we don't tidy the OccNames, and if we don't remove - -- the non-exported ones we'll get many things with the - -- same name in the interface file, giving chaos. - -- - -- Do make sure that we keep Ids that are already Global. - -- When typechecking an .hs-boot file, the Ids come through as - -- GlobalIds. - final_ids = [ (if isLocalId id then globaliseAndTidyId id - else id) - `setIdUnfolding` BootUnfolding - | id <- ids + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ globaliseAndTidyBootId id + | id <- typeEnvIds type_env , keep_it id ] - -- default methods have their export flag set, but everything - -- else doesn't (yet), because this is pre-desugaring, so we - -- must test both. - keep_it id = isExportedId id || idName id `elemNameSet` exports + final_tcs = filterOut (isWiredInName . getName) tcs + -- See Note [Drop wired-in things] + type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts + insts' = mkFinalClsInsts type_env1 insts + pat_syns' = mkFinalPatSyns type_env1 pat_syns + type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 + -- Default methods have their export flag set (isExportedId), + -- but everything else doesn't (yet), because this is + -- pre-desugaring, so we must test against the exports too. + keep_it id | isWiredInName id_name = False + -- See Note [Drop wired-in things] + | isExportedId id = True + | id_name `elemNameSet` exp_names = True + | otherwise = False + where + id_name = idName id + exp_names = availsToNameSet exports -globaliseAndTidyId :: Id -> Id --- Takes a LocalId with an External Name, +lookupFinalId :: TypeEnv -> Id -> Id +lookupFinalId type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _ -> pprPanic "lookup_final_id" (ppr id) + +mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] +mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) + +mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] +mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) + +extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv +extendTypeEnvWithPatSyns tidy_patsyns type_env + = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] + +globaliseAndTidyBootId :: Id -> Id +-- For a LocalId with an External Name, -- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details --- * VanillaIdInfo (makes a conservative assumption about Caf-hood) -globaliseAndTidyId id - = Id.setIdType (globaliseId id) tidy_type - where - tidy_type = tidyTopType (idType id) +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity) +-- * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface) +globaliseAndTidyBootId id + = globaliseId id `setIdType` tidyTopType (idType id) + `setIdUnfolding` BootUnfolding {- ************************************************************************ @@ -335,13 +347,7 @@ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; print_unqual = mkPrintUnqualified dflags rdr_env - } - - ; let { type_env = typeEnvFromEntities [] tcs fam_insts - - ; implicit_binds - = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ - concatMap getTyConImplicitBinds (typeEnvTyCons type_env) + ; implicit_binds = concatMap getImplicitBinds tcs } ; (unfold_env, tidy_occ_env) @@ -353,30 +359,6 @@ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds - ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, - isExternalName (idName id)] - ; type_env1 = extendTypeEnvWithIds type_env final_ids - - ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts - -- A DFunId will have a binding in tidy_binds, and so will now be in - -- tidy_type_env, replete with IdInfo. Its name will be unchanged since - -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the - -- tidy_cls_insts. Similarly the Ids inside a PatSyn. - - ; tidy_rules = tidyRules tidy_env trimmed_rules - -- You might worry that the tidy_env contains IdInfo-rich stuff - -- and indeed it does, but if omit_prags is on, ext_rules is - -- empty - - -- Tidy the Ids inside each PatSyn, very similarly to DFunIds - -- and then override the PatSyns in the type_env with the new tidy ones - -- This is really the only reason we keep mg_patsyns at all; otherwise - -- they could just stay in type_env - ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns - ; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1 - - ; tidy_type_env = tidyTypeEnv omit_prags type_env2 - } -- See Note [Grand plan for static forms] in StaticPtrTable. ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds @@ -388,20 +370,44 @@ HscInterpreted -> id -- otherwise add a C stub to do so _ -> (`appendStubC` spt_init_code) - } - ; let { -- See Note [Injecting implicit bindings] + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + ; final_ids = [ if omit_prags then trimId id else id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredInName (getName id)) + ] -- See Note [Drop wired-in things] + + ; final_tcs = filterOut (isWiredInName . getName) tcs + -- See Note [Drop wired-in things] + ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts + ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts + ; tidy_patsyns = mkFinalPatSyns type_env patsyns + ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + ; tidy_rules = tidyRules tidy_env trimmed_rules + + ; -- See Note [Injecting implicit bindings] all_tidy_binds = implicit_binds ++ tidy_binds' -- Get the TyCons to generate code for. Careful! We must use - -- the untidied TypeEnv here, because we need + -- the untidied TyCons here, because we need -- (a) implicit TyCons arising from types and classes defined -- in this module -- (b) wired-in TyCons, which are normally removed from the -- TypeEnv we put in the ModDetails -- (c) Constructors even if they are not exported (the -- tidied TypeEnv has trimmed these away) - ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + ; alg_tycons = filter isAlgTyCon tcs } ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules @@ -444,46 +450,19 @@ where dflags = hsc_dflags hsc_env -tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> TypeEnv -> TypeEnv - --- The completed type environment is gotten from --- a) the types and classes defined here (plus implicit things) --- b) adding Ids with correct IdInfo, including unfoldings, --- gotten from the bindings --- From (b) we keep only those Ids with External names; --- the CoreTidy pass makes sure these are all and only --- the externally-accessible ones --- This truncates the type environment to include only the --- exported Ids and things needed from them, which saves space --- --- See Note [Don't attempt to trim data types] - -tidyTypeEnv omit_prags type_env - = let - type_env1 = filterNameEnv (not . isWiredInName . getName) type_env - -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv trimThing type_env1 - | otherwise = type_env1 - -- (2) trimmed if necessary - in - type_env2 - -------------------------- -trimThing :: TyThing -> TyThing --- Trim off inessentials, for boot files and no -O -trimThing (AnId id) - | not (isImplicitId id) - = AnId (id `setIdInfo` vanillaIdInfo) - -trimThing other_thing - = other_thing +trimId :: Id -> Id +trimId id + | not (isImplicitId id) + = id `setIdInfo` vanillaIdInfo + | otherwise + = id -extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv -extendTypeEnvWithPatSyns tidy_patsyns type_env - = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] +{- Note [Drop wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never put wired-in TyCons or Ids in an interface file. +They are wired-in, so the compiler knows about them already. -{- Note [Don't attempt to trim data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For some time GHC tried to avoid exporting the data constructors @@ -565,8 +544,15 @@ See Note [Data constructor workers] in CorePrep. -} +getImplicitBinds :: TyCon -> [CoreBind] +getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc + where + cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) + getTyConImplicitBinds :: TyCon -> [CoreBind] -getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) +getTyConImplicitBinds tc + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId + | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls @@ -751,9 +737,7 @@ -- we don't want to record these as free vars -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far -> ((VarSet,[Var]),a)) -- Output state - -instance Functor DFFV where - fmap = liftM + deriving (Functor) instance Applicative DFFV where pure a = DFFV $ \_ st -> (st, a) @@ -1301,7 +1285,48 @@ In particular CorePrep expands Integer and Natural literals. So in the prediction code here we resort to applying the same expansion (cvt_literal). -Ugh! +There are also numberous other ways in which we can introduce inconsistencies +between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta +expansion in TidyPgm] for one such example. + +Ugh! What ugliness we hath wrought. + + +Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Eta expansion during CorePrep can have non-obvious negative consequences on +the CAFfyness computation done by TidyPgm (see Note [Disgusting computation of +CafRefs] in TidyPgm). This late expansion happens/happened for a few reasons: + + * CorePrep previously eta expanded unsaturated primop applications, as + described in Note [Primop wrappers]). + + * CorePrep still does eta expand unsaturated data constructor applications. + +In particular, consider the program: + + data Ty = Ty (RealWorld# -> (# RealWorld#, Int #)) + + -- Is this CAFfy? + x :: STM Int + x = Ty (retry# @Int) + +Consider whether x is CAFfy. One might be tempted to answer "no". +Afterall, f obviously has no CAF references and the application (retry# +@Int) is essentially just a variable reference at runtime. + +However, when CorePrep expanded the unsaturated application of 'retry#' +it would rewrite this to + + x = \u [] + let sat = retry# @Int + in Ty sat + +This is now a CAF. Failing to handle this properly was the cause of +#16846. We fixed this by eliminating the need to eta expand primops, as +described in Note [Primop wrappers]), However we have not yet done the same for +data constructor applications. + -} type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -6,7 +6,8 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-} +{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms, + DeriveFunctor #-} #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} @@ -59,7 +60,7 @@ import AsmUtils import TargetReg -import Platform +import GHC.Platform import BlockLayout import Config import Instruction @@ -1038,13 +1039,11 @@ {-# COMPLETE OptMResult #-} #else -data OptMResult a = OptMResult !a ![CLabel] +data OptMResult a = OptMResult !a ![CLabel] deriving (Functor) #endif newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a) - -instance Functor CmmOptM where - fmap = liftM + deriving (Functor) instance Applicative CmmOptM where pure x = CmmOptM $ \_ _ imports -> OptMResult x imports diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs --- a/compiler/nativeGen/Dwarf.hs +++ b/compiler/nativeGen/Dwarf.hs @@ -12,7 +12,7 @@ import DynFlags import Module import Outputable -import Platform +import GHC.Platform import Unique import UniqSupply diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs --- a/compiler/nativeGen/Dwarf/Constants.hs +++ b/compiler/nativeGen/Dwarf/Constants.hs @@ -7,7 +7,7 @@ import AsmUtils import FastString -import Platform +import GHC.Platform import Outputable import Reg diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -30,7 +30,7 @@ import Encoding import FastString import Outputable -import Platform +import GHC.Platform import Unique import Reg import SrcLoc diff --git a/compiler/nativeGen/Format.hs b/compiler/nativeGen/Format.hs --- a/compiler/nativeGen/Format.hs +++ b/compiler/nativeGen/Format.hs @@ -10,9 +10,11 @@ -- module Format ( Format(..), + ScalarFormat(..), intFormat, floatFormat, isFloatFormat, + isVecFormat, cmmTypeFormat, formatToWidth, formatInBytes @@ -25,6 +27,29 @@ import Cmm import Outputable + +-- Note [GHC's data format representations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- GHC has severals types that represent various aspects of data format. +-- These include: +-- +-- * 'CmmType.CmmType': The data classification used throughout the C-- +-- pipeline. This is a pair of a CmmCat and a Width. +-- +-- * 'CmmType.CmmCat': What the bits in a C-- value mean (e.g. a pointer, integer, or floating-point value) +-- +-- * 'CmmType.Width': The width of a C-- value. +-- +-- * 'CmmType.Length': The width (measured in number of scalars) of a vector value. +-- +-- * 'Format.Format': The data format representation used by much of the backend. +-- +-- * 'Format.ScalarFormat': The format of a 'Format.VecFormat'\'s scalar. +-- +-- * 'RegClass.RegClass': Whether a register is an integer, float-point, or vector register +-- + -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator. You can change it -- without global consequences. @@ -47,8 +72,16 @@ | II64 | FF32 | FF64 + | VecFormat !Length !ScalarFormat !Width deriving (Show, Eq) +data ScalarFormat = FmtInt8 + | FmtInt16 + | FmtInt32 + | FmtInt64 + | FmtFloat + | FmtDouble + deriving (Show, Eq) -- | Get the integer format of this width. intFormat :: Width -> Format @@ -81,13 +114,33 @@ FF64 -> True _ -> False +-- | Check if a format represents a vector +isVecFormat :: Format -> Bool +isVecFormat (VecFormat {}) = True +isVecFormat _ = False -- | Convert a Cmm type to a Format. cmmTypeFormat :: CmmType -> Format cmmTypeFormat ty | isFloatType ty = floatFormat (typeWidth ty) + | isVecType ty = vecFormat ty | otherwise = intFormat (typeWidth ty) +vecFormat :: CmmType -> Format +vecFormat ty = + let l = vecLength ty + elemTy = vecElemType ty + in if isFloatType elemTy + then case typeWidth elemTy of + W32 -> VecFormat l FmtFloat W32 + W64 -> VecFormat l FmtDouble W64 + _ -> pprPanic "Incorrect vector element width" (ppr elemTy) + else case typeWidth elemTy of + W8 -> VecFormat l FmtInt8 W8 + W16 -> VecFormat l FmtInt16 W16 + W32 -> VecFormat l FmtInt32 W32 + W64 -> VecFormat l FmtInt64 W64 + _ -> pprPanic "Incorrect vector element width" (ppr elemTy) -- | Get the Width of a Format. formatToWidth :: Format -> Width @@ -99,7 +152,7 @@ II64 -> W64 FF32 -> W32 FF64 -> W64 - + VecFormat l _ w -> widthFromBytes (l*widthInBytes w) formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -23,7 +23,7 @@ import Hoopl.Label import DynFlags import Cmm hiding (topInfoTable) -import Platform +import GHC.Platform -- | Holds a list of source and destination registers used by a -- particular instruction. diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} -- ----------------------------------------------------------------------------- -- @@ -59,7 +60,7 @@ import DynFlags import Module -import Control.Monad ( liftM, ap ) +import Control.Monad ( ap ) import Instruction import Outputable (SDoc, pprPanic, ppr) @@ -113,6 +114,7 @@ type DwarfFiles = UniqFM (FastString, Int) newtype NatM result = NatM (NatM_State -> (result, NatM_State)) + deriving (Functor) unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a @@ -138,9 +140,6 @@ initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) } -instance Functor NatM where - fmap = liftM - instance Applicative NatM where pure = returnNat (<*>) = ap @@ -250,7 +249,6 @@ = do u <- getUniqueNat dflags <- getDynFlags return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) - getNewRegPairNat :: Format -> NatM (Reg,Reg) getNewRegPairNat rep diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -54,7 +54,7 @@ import qualified X86.Instr as X86 -import Platform +import GHC.Platform import Instruction import Reg import NCGMonad diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -41,7 +41,7 @@ import RegClass import Reg import TargetReg -import Platform +import GHC.Platform -- Our intermediate code: import BlockId @@ -1123,6 +1123,8 @@ -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock +genCCall (PrimTarget MO_ReadBarrier) _ _ + = return $ unitOL LWSYNC genCCall (PrimTarget MO_WriteBarrier) _ _ = return $ unitOL LWSYNC @@ -1907,6 +1909,8 @@ FF32 -> (1, 1, 4, fprs) FF64 -> (2, 1, 8, fprs) II64 -> panic "genCCall' passArguments II64" + VecFormat {} + -> panic "genCCall' passArguments vector format" GCP32ELF -> case cmmTypeFormat rep of @@ -1917,6 +1921,8 @@ FF32 -> (0, 1, 4, fprs) FF64 -> (0, 1, 8, fprs) II64 -> panic "genCCall' passArguments II64" + VecFormat {} + -> panic "genCCall' passArguments vector format" GCP64ELF _ -> case cmmTypeFormat rep of II8 -> (1, 0, 8, gprs) @@ -1928,6 +1934,8 @@ -- the FPRs. FF32 -> (1, 1, 8, fprs) FF64 -> (1, 1, 8, fprs) + VecFormat {} + -> panic "genCCall' passArguments vector format" moveResult reduceToFF32 = case dest_regs of @@ -1955,7 +1963,9 @@ where (functionName, reduce) = case mop of MO_F32_Exp -> (fsLit "exp", True) + MO_F32_ExpM1 -> (fsLit "expm1", True) MO_F32_Log -> (fsLit "log", True) + MO_F32_Log1P -> (fsLit "log1p", True) MO_F32_Sqrt -> (fsLit "sqrt", True) MO_F32_Fabs -> unsupported @@ -1977,7 +1987,9 @@ MO_F32_Atanh -> (fsLit "atanh", True) MO_F64_Exp -> (fsLit "exp", False) + MO_F64_ExpM1 -> (fsLit "expm1", False) MO_F64_Log -> (fsLit "log", False) + MO_F64_Log1P -> (fsLit "log1p", False) MO_F64_Sqrt -> (fsLit "sqrt", False) MO_F64_Fabs -> unsupported @@ -2026,6 +2038,7 @@ MO_AddIntC {} -> unsupported MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported MO_Prefetch_Data _ -> unsupported diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -43,7 +43,7 @@ import FastString import CLabel import Outputable -import Platform +import GHC.Platform import UniqFM (listToUFM, lookupUFM) import UniqSupply diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -29,8 +29,8 @@ import CLabel import PprCmmExpr () -import Unique ( pprUniqueAlways, getUnique ) -import Platform +import Unique ( getUnique ) +import GHC.Platform import FastString import Outputable import DynFlags @@ -168,10 +168,7 @@ = case r of RegReal (RealRegSingle i) -> ppr_reg_no i RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u - RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u - RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + RegVirtual v -> ppr v where ppr_reg_no :: Int -> SDoc @@ -190,7 +187,8 @@ II32 -> sLit "w" II64 -> sLit "d" FF32 -> sLit "fs" - FF64 -> sLit "fd") + FF64 -> sLit "fd" + VecFormat _ _ _ -> panic "PPC.Ppr.pprFormat: VecFormat") pprCond :: Cond -> SDoc @@ -375,6 +373,7 @@ II64 -> sLit "d" FF32 -> sLit "fs" FF64 -> sLit "fd" + VecFormat _ _ _ -> panic "PPC.Ppr.pprInstr: VecFormat" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', @@ -414,6 +413,7 @@ II64 -> sLit "d" FF32 -> sLit "fs" FF64 -> sLit "fd" + VecFormat _ _ _ -> panic "PPC.Ppr.pprInstr: VecFormat" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -63,7 +63,7 @@ import CodeGen.Platform import DynFlags import Outputable -import Platform +import GHC.Platform import Data.Word ( Word8, Word16, Word32, Word64 ) import Data.Int ( Int8, Int16, Int32, Int64 ) diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs --- a/compiler/nativeGen/PprBase.hs +++ b/compiler/nativeGen/PprBase.hs @@ -28,7 +28,7 @@ import DynFlags import FastString import Outputable -import Platform +import GHC.Platform import FileCleanup import qualified Data.Array.Unsafe as U ( castSTUArray ) diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -56,6 +56,7 @@ | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register | VirtualRegF {-# UNPACK #-} !Unique | VirtualRegD {-# UNPACK #-} !Unique + | VirtualRegVec {-# UNPACK #-} !Unique deriving (Eq, Show) @@ -69,6 +70,7 @@ compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b + compare (VirtualRegVec a) (VirtualRegVec b) = nonDetCmpUnique a b compare VirtualRegI{} _ = LT compare _ VirtualRegI{} = GT @@ -76,7 +78,8 @@ compare _ VirtualRegHi{} = GT compare VirtualRegF{} _ = LT compare _ VirtualRegF{} = GT - + compare VirtualRegVec{} _ = LT + compare _ VirtualRegVec{} = GT instance Uniquable VirtualReg where @@ -86,6 +89,7 @@ VirtualRegHi u -> u VirtualRegF u -> u VirtualRegD u -> u + VirtualRegVec u -> u instance Outputable VirtualReg where ppr reg @@ -95,8 +99,9 @@ -- this code is kinda wrong on x86 -- because float and double occupy the same register set -- namely SSE2 register xmm0 .. xmm15 - VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u - VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u + VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u + VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u + VirtualRegVec u -> text "%vVec_" <> pprUniqueAlways u @@ -107,6 +112,7 @@ VirtualRegHi _ -> VirtualRegHi u VirtualRegF _ -> VirtualRegF u VirtualRegD _ -> VirtualRegD u + VirtualRegVec _ -> VirtualRegVec u classOfVirtualReg :: VirtualReg -> RegClass @@ -116,6 +122,8 @@ VirtualRegHi{} -> RcInteger VirtualRegF{} -> RcFloat VirtualRegD{} -> RcDouble + -- Below is an awful, largely x86-specific hack + VirtualRegVec{} -> RcDouble diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -21,7 +21,7 @@ import Bag import DynFlags import Outputable -import Platform +import GHC.Platform import UniqFM import UniqSet import UniqSupply diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -23,7 +23,7 @@ import UniqSet import UniqSupply import Outputable -import Platform +import GHC.Platform import Data.List import Data.Maybe diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -41,7 +41,7 @@ import Unique import State import Outputable -import Platform +import GHC.Platform import Hoopl.Collections import Data.List diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -28,7 +28,7 @@ import UniqSet import Digraph (flattenSCCs) import Outputable -import Platform +import GHC.Platform import State import CFG diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -16,7 +16,7 @@ import GraphBase import UniqSet -import Platform +import GHC.Platform import Panic -- trivColorable --------------------------------------------------------------- @@ -192,7 +192,6 @@ exclusions = count3 < cALLOCATABLE_REGS_DOUBLE - diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -2,6 +2,7 @@ module RegAlloc.Linear.FreeRegs ( FR(..), + allFreeRegs, maxSpillSlots ) @@ -16,7 +17,7 @@ import DynFlags import Panic -import Platform +import GHC.Platform -- ----------------------------------------------------------------------------- -- The free register set @@ -68,6 +69,10 @@ frGetFreeRegs = \_ -> SPARC.getFreeRegs frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg + +-- | For debugging output. +allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg] +allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses maxSpillSlots :: DynFlags -> Int maxSpillSlots dflags diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -130,7 +130,7 @@ import UniqFM import UniqSupply import Outputable -import Platform +import GHC.Platform import Data.Maybe import Data.List @@ -884,8 +884,10 @@ $ vcat [ text "allocating vreg: " <> text (show r) , text "assignment: " <> ppr assig - , text "freeRegs: " <> text (show freeRegs) - , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] + , text "freeRegs: " <> text (showRegs freeRegs) + , text "initFreeRegs: " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs)) + ] + where showRegs = show . map (\reg -> (reg, targetClassOfRealReg platform reg)) . allFreeRegs platform result diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs --- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs @@ -9,7 +9,7 @@ import Reg import Outputable -import Platform +import GHC.Platform import Data.Word import Data.Bits diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs --- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -11,7 +11,7 @@ import CodeGen.Platform import Outputable -import Platform +import GHC.Platform import Data.Word import Data.Bits diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, PatternSynonyms #-} +{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-} #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} @@ -50,7 +50,7 @@ import Unique import UniqSupply -import Control.Monad (liftM, ap) +import Control.Monad (ap) -- Avoids using unboxed tuples when loading into GHCi #if !defined(GHC_LOADED_INTO_GHCI) @@ -63,15 +63,14 @@ #else data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a + deriving (Functor) #endif -- | The register allocator monad type. newtype RegM freeRegs a = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a } - -instance Functor (RegM freeRegs) where - fmap = liftM + deriving (Functor) instance Applicative (RegM freeRegs) where pure a = RegM $ \s -> RA_Result s a diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs --- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -9,7 +9,7 @@ import RegClass import Reg import Panic -import Platform +import GHC.Platform import Data.Word import Data.Bits diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs --- a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs @@ -9,7 +9,7 @@ import RegClass import Reg import Panic -import Platform +import GHC.Platform import Data.Word import Data.Bits diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -51,7 +51,7 @@ import DynFlags import MonadUtils import Outputable -import Platform +import GHC.Platform import UniqSet import UniqFM import UniqSupply diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -1,15 +1,14 @@ -- | An architecture independent description of a register's class. module RegClass - ( RegClass (..) ) - -where + ( RegClass(..) + , allRegClasses + ) where import GhcPrelude import Outputable import Unique - -- | The class of a register. -- Used in the register allocator. -- We treat all registers in a class as being interchangable. @@ -18,15 +17,19 @@ = RcInteger | RcFloat | RcDouble - deriving Eq + deriving (Eq, Show) +allRegClasses :: [RegClass] +allRegClasses = + [ RcInteger, RcFloat, RcDouble ] + instance Uniquable RegClass where getUnique RcInteger = mkRegClassUnique 0 getUnique RcFloat = mkRegClassUnique 1 getUnique RcDouble = mkRegClassUnique 2 instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -59,7 +59,7 @@ import FastString import OrdList import Outputable -import Platform +import GHC.Platform import Control.Monad ( mapAndUnzipM ) @@ -401,6 +401,8 @@ -- -- In the SPARC case we don't need a barrier. -- +genCCall (PrimTarget MO_ReadBarrier) _ _ + = return $ nilOL genCCall (PrimTarget MO_WriteBarrier) _ _ = return $ nilOL @@ -616,7 +618,9 @@ outOfLineMachOp_table mop = case mop of MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" MO_F32_Sqrt -> fsLit "sqrtf" MO_F32_Fabs -> unsupported MO_F32_Pwr -> fsLit "powf" @@ -638,7 +642,9 @@ MO_F32_Atanh -> fsLit "atanhf" MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" MO_F64_Sqrt -> fsLit "sqrt" MO_F64_Fabs -> unsupported MO_F64_Pwr -> fsLit "pow" @@ -687,6 +693,7 @@ MO_AddIntC {} -> unsupported MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported (MO_Prefetch_Data _) -> unsupported diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -26,7 +26,7 @@ import DynFlags import Cmm import PprCmmExpr () -import Platform +import GHC.Platform import Outputable import OrdList diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -46,7 +46,7 @@ import Cmm import FastString import Outputable -import Platform +import GHC.Platform -- | Register or immediate diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -45,9 +45,8 @@ import Hoopl.Label import Hoopl.Collections -import Unique ( pprUniqueAlways ) import Outputable -import Platform +import GHC.Platform import FastString -- ----------------------------------------------------------------------------- @@ -148,12 +147,7 @@ pprReg reg = case reg of RegVirtual vr - -> case vr of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - VirtualRegF u -> text "%vF_" <> pprUniqueAlways u - VirtualRegD u -> text "%vD_" <> pprUniqueAlways u - + -> ppr vr RegReal rr -> case rr of @@ -221,7 +215,8 @@ II32 -> sLit "" II64 -> sLit "d" FF32 -> sLit "" - FF64 -> sLit "d") + FF64 -> sLit "d" + VecFormat _ _ _ -> panic "SPARC.Ppr.pprFormat: VecFormat") -- | Pretty print a format for an instruction suffix. @@ -235,7 +230,8 @@ II32 -> sLit "" II64 -> sLit "x" FF32 -> sLit "" - FF64 -> sLit "d") + FF64 -> sLit "d" + VecFormat _ _ _ -> panic "SPARC.Ppr.pprFormat: VecFormat") diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -104,7 +104,6 @@ VirtualRegD{} -> 1 _other -> 0 - {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int @@ -133,7 +132,6 @@ | otherwise -> 1 RealRegPair{} -> 1 - -- | All the allocatable registers in the machine, -- including register pairs. diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -29,7 +29,7 @@ import Outputable import Unique -import Platform +import GHC.Platform import qualified X86.Regs as X86 import qualified X86.RegInfo as X86 diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -54,7 +54,7 @@ import CFG import Format import Reg -import Platform +import GHC.Platform -- Our intermediate code: import BasicTypes @@ -111,13 +111,26 @@ ArchX86 -> return True _ -> panic "trying to generate x86/x86_64 on the wrong platform" +sse4_1Enabled :: NatM Bool +sse4_1Enabled = do + dflags <- getDynFlags + return (isSse4_1Enabled dflags) sse4_2Enabled :: NatM Bool sse4_2Enabled = do dflags <- getDynFlags return (isSse4_2Enabled dflags) +sseEnabled :: NatM Bool +sseEnabled = do + dflags <- getDynFlags + return (isSseEnabled dflags) +avxEnabled :: NatM Bool +avxEnabled = do + dflags <- getDynFlags + return (isAvxEnabled dflags) + cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] @@ -215,6 +228,7 @@ CmmAssign reg src | isFloatType ty -> assignReg_FltCode format reg src | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | isVecType ty -> assignReg_VecCode format reg src | otherwise -> assignReg_IntCode format reg src where ty = cmmRegType dflags reg format = cmmTypeFormat ty @@ -222,6 +236,7 @@ CmmStore addr src | isFloatType ty -> assignMem_FltCode format addr src | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | isVecType ty -> assignMem_VecCode format addr src | otherwise -> assignMem_IntCode format addr src where ty = cmmExprType dflags src format = cmmTypeFormat ty @@ -308,6 +323,15 @@ -- platform. Hence ... +getVecRegisterReg :: Platform -> Bool -> Format -> CmmReg -> Reg +getVecRegisterReg _ use_avx format (CmmLocal (LocalReg u pk)) + | isVecType pk && use_avx = RegVirtual (mkVirtualReg u format) + | otherwise = pprPanic + (unlines ["avx flag is not enabled" , + "or this is not a vector register"]) + (ppr pk) +getVecRegisterReg platform _use_avx _format c = getRegisterReg platform c + -- | Memory addressing modes passed up the tree. data Amode = Amode AddrMode InstrBlock @@ -503,6 +527,13 @@ -------------------------------------------------------------------------------- + +-- This is a helper data type which helps reduce the code duplication for +-- the code generation of arithmetic operations. This is not specifically +-- targetted for any particular type like Int8, Int32 etc +data VectorArithInstns = VA_Add | VA_Sub | VA_Mul | VA_Div + + getRegister :: CmmExpr -> NatM Register getRegister e = do dflags <- getDynFlags is32Bit <- is32BitPlatform @@ -520,16 +551,24 @@ do reg' <- getPicBaseNat (archWordFormat is32Bit) return (Fixed (archWordFormat is32Bit) reg' nilOL) _ -> - do - let - fmt = cmmTypeFormat (cmmRegType dflags reg) - format = fmt - -- - let platform = targetPlatform dflags - return (Fixed format - (getRegisterReg platform reg) - nilOL) + do use_sse2 <- sse2Enabled + use_avx <- avxEnabled + let cmmregtype = cmmRegType dflags reg + if isVecType cmmregtype + then return (vectorRegister cmmregtype use_avx use_sse2) + else return (standardRegister cmmregtype) + where + vectorRegister :: CmmType -> Bool -> Bool -> Register + vectorRegister reg_ty use_avx use_sse2 + | use_avx || use_sse2 = + let vecfmt = cmmTypeFormat reg_ty + platform = targetPlatform dflags + in (Fixed vecfmt (getVecRegisterReg platform True vecfmt reg) nilOL) + | otherwise = panic "Please enable the -mavx or -msse2 flag" + standardRegister crt = + let platform = targetPlatform dflags + in (Fixed (cmmTypeFormat crt) (getRegisterReg platform reg) nilOL) getRegister' dflags is32Bit (CmmRegOff r n) = getRegister' dflags is32Bit $ mangleIndexTree dflags r n @@ -631,7 +670,69 @@ return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) +getRegister' _ _ (CmmMachOp mop [x, y, z]) = do -- ternary MachOps + sse4_1 <- sse4_1Enabled + sse2 <- sse2Enabled + sse <- sseEnabled + case mop of + MO_VF_Insert l W32 | sse4_1 && sse -> vector_float_pack l W32 x y z + | otherwise + -> sorry "Please enable the -msse4 and -msse flag" + MO_VF_Insert l W64 | sse2 && sse -> vector_float_pack l W64 x y z + | otherwise + -> sorry "Please enable the -msse2 and -msse flag" + _other -> incorrectOperands + where + vector_float_pack :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_pack len W32 expr1 expr2 (CmmLit offset) + = do + fn <- getAnyReg expr1 + (r, exp) <- getSomeReg expr2 + let f = VecFormat len FmtFloat W32 + imm = litToImm offset + code dst = exp `appOL` + (fn dst) `snocOL` + (INSERTPS f (OpImm imm) (OpReg r) dst) + in return $ Any f code + vector_float_pack len W64 expr1 expr2 (CmmLit offset) + = do + Amode addr addr_code <- getAmode expr2 + (r, exp) <- getSomeReg expr1 + + -- fn <- getAnyReg expr1 + -- (r, exp) <- getSomeReg expr2 + let f = VecFormat len FmtDouble W64 + code dst + = case offset of + CmmInt 0 _ -> exp `appOL` addr_code `snocOL` + (MOVL f (OpAddr addr) (OpReg r)) `snocOL` + (MOVU f (OpReg r) (OpReg dst)) + CmmInt 16 _ -> exp `appOL` addr_code `snocOL` + (MOVH f (OpAddr addr) (OpReg r)) `snocOL` + (MOVU f (OpReg r) (OpReg dst)) + _ -> panic "Error in offset while packing" + -- code dst + -- = case offset of + -- CmmInt 0 _ -> exp `appOL` + -- (fn dst) `snocOL` + -- (MOVL f (OpReg r) (OpReg dst)) + -- CmmInt 16 _ -> exp `appOL` + -- (fn dst) `snocOL` + -- (MOVH f (OpReg r) (OpReg dst)) + -- _ -> panic "Error in offset while packing" + in return $ Any f code + vector_float_pack _ _ _ c _ + = pprPanic "Pack not supported for : " (ppr c) + getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps + sse2 <- sse2Enabled + sse <- sseEnabled + avx <- avxEnabled case mop of MO_F_Neg w -> sse2NegCode w x @@ -708,24 +809,29 @@ MO_FS_Conv from to -> coerceFP2Int from to x MO_SF_Conv from to -> coerceInt2FP from to x - MO_V_Insert {} -> needLlvm - MO_V_Extract {} -> needLlvm - MO_V_Add {} -> needLlvm - MO_V_Sub {} -> needLlvm - MO_V_Mul {} -> needLlvm - MO_VS_Quot {} -> needLlvm - MO_VS_Rem {} -> needLlvm - MO_VS_Neg {} -> needLlvm - MO_VU_Quot {} -> needLlvm - MO_VU_Rem {} -> needLlvm - MO_VF_Insert {} -> needLlvm - MO_VF_Extract {} -> needLlvm - MO_VF_Add {} -> needLlvm - MO_VF_Sub {} -> needLlvm - MO_VF_Mul {} -> needLlvm - MO_VF_Quot {} -> needLlvm - MO_VF_Neg {} -> needLlvm + MO_V_Insert {} -> needLlvm + MO_V_Extract {} -> needLlvm + MO_V_Add {} -> needLlvm + MO_V_Sub {} -> needLlvm + MO_V_Mul {} -> needLlvm + MO_VS_Quot {} -> needLlvm + MO_VS_Rem {} -> needLlvm + MO_VS_Neg {} -> needLlvm + MO_VU_Quot {} -> needLlvm + MO_VU_Rem {} -> needLlvm + MO_VF_Broadcast {} -> incorrectOperands + MO_VF_Insert {} -> incorrectOperands + MO_VF_Extract {} -> incorrectOperands + MO_VF_Add {} -> incorrectOperands + MO_VF_Sub {} -> incorrectOperands + MO_VF_Mul {} -> incorrectOperands + MO_VF_Quot {} -> incorrectOperands + MO_VF_Neg l w | avx -> vector_float_negate_avx l w x + | sse && sse2 -> vector_float_negate_sse l w x + | otherwise + -> sorry "Please enable the -mavx or -msse, -msse2 flag" + _other -> pprPanic "getRegister" (pprMachOp mop) where triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register @@ -762,8 +868,45 @@ = do e_code <- getRegister' dflags is32Bit expr return (swizzleRegisterRep e_code new_format) + vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register + vector_float_negate_avx l w expr = do + tmp <- getNewRegNat (VecFormat l FmtFloat w) + (reg, exp) <- getSomeReg expr + Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes W32) (CmmFloat 0.0 W32) + let format = case w of + W32 -> VecFormat l FmtFloat w + W64 -> VecFormat l FmtDouble w + _ -> pprPanic "Cannot negate vector of width" (ppr w) + code dst = case w of + W32 -> exp `appOL` addr_code `snocOL` + (VBROADCAST format addr tmp) `snocOL` + (VSUB format (OpReg reg) tmp dst) + W64 -> exp `appOL` addr_code `snocOL` + (MOVL format (OpAddr addr) (OpReg tmp)) `snocOL` + (MOVH format (OpAddr addr) (OpReg tmp)) `snocOL` + (VSUB format (OpReg reg) tmp dst) + _ -> pprPanic "Cannot negate vector of width" (ppr w) + return (Any format code) + vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register + vector_float_negate_sse l w expr = do + tmp <- getNewRegNat (VecFormat l FmtFloat w) + (reg, exp) <- getSomeReg expr + let format = case w of + W32 -> VecFormat l FmtFloat w + W64 -> VecFormat l FmtDouble w + _ -> pprPanic "Cannot negate vector of width" (ppr w) + code dst = exp `snocOL` + (XOR format (OpReg tmp) (OpReg tmp)) `snocOL` + (MOVU format (OpReg tmp) (OpReg dst)) `snocOL` + (SUB format (OpReg reg) (OpReg dst)) + return (Any format code) + getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps + sse4_1 <- sse4_1Enabled + sse2 <- sse2Enabled + sse <- sseEnabled + avx <- avxEnabled case mop of MO_F_Eq _ -> condFltReg is32Bit EQQ x y MO_F_Ne _ -> condFltReg is32Bit NE x y @@ -828,14 +971,50 @@ MO_VS_Quot {} -> needLlvm MO_VS_Rem {} -> needLlvm MO_VS_Neg {} -> needLlvm - MO_VF_Insert {} -> needLlvm - MO_VF_Extract {} -> needLlvm - MO_VF_Add {} -> needLlvm - MO_VF_Sub {} -> needLlvm - MO_VF_Mul {} -> needLlvm - MO_VF_Quot {} -> needLlvm - MO_VF_Neg {} -> needLlvm + MO_VF_Broadcast l W32 | avx -> vector_float_broadcast_avx l W32 x y + | sse4_1 -> vector_float_broadcast_sse l W32 x y + | otherwise + -> sorry "Please enable the -mavx or -msse4 flag" + + MO_VF_Broadcast l W64 | sse2 -> vector_float_broadcast_avx l W64 x y + | otherwise -> sorry "Please enable the -msse2 flag" + + MO_VF_Extract l W32 | avx -> vector_float_unpack l W32 x y + | sse -> vector_float_unpack_sse l W32 x y + | otherwise + -> sorry "Please enable the -mavx or -msse flag" + + MO_VF_Extract l W64 | sse2 -> vector_float_unpack l W64 x y + | otherwise -> sorry "Please enable the -msse2 flag" + + MO_VF_Add l w | avx -> vector_float_op_avx VA_Add l w x y + | sse && w == W32 -> vector_float_op_sse VA_Add l w x y + | sse2 && w == W64 -> vector_float_op_sse VA_Add l w x y + | otherwise + -> sorry "Please enable the -mavx or -msse flag" + + MO_VF_Sub l w | avx -> vector_float_op_avx VA_Sub l w x y + | sse && w == W32 -> vector_float_op_sse VA_Sub l w x y + | sse2 && w == W64 -> vector_float_op_sse VA_Sub l w x y + | otherwise + -> sorry "Please enable the -mavx or -msse flag" + + MO_VF_Mul l w | avx -> vector_float_op_avx VA_Mul l w x y + | sse && w == W32 -> vector_float_op_sse VA_Mul l w x y + | sse2 && w == W64 -> vector_float_op_sse VA_Mul l w x y + | otherwise + -> sorry "Please enable the -mavx or -msse flag" + + MO_VF_Quot l w | avx -> vector_float_op_avx VA_Div l w x y + | sse && w == W32 -> vector_float_op_sse VA_Div l w x y + | sse2 && w == W64 -> vector_float_op_sse VA_Div l w x y + | otherwise + -> sorry "Please enable the -mavx or -msse flag" + + MO_VF_Insert {} -> incorrectOperands + MO_VF_Neg {} -> incorrectOperands + _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) where -------------------- @@ -930,7 +1109,171 @@ -- TODO: There are other interesting patterns we want to replace -- with a LEA, e.g. `(x + offset) + (y << shift)`. + ----------------------- + -- Vector operations--- + vector_float_op_avx :: VectorArithInstns + -> Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_op_avx op l w expr1 expr2 = do + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let format = case w of + W32 -> VecFormat l FmtFloat W32 + W64 -> VecFormat l FmtDouble W64 + _ -> pprPanic "Operation not supported for width " (ppr w) + code dst = case op of + VA_Add -> arithInstr VADD + VA_Sub -> arithInstr VSUB + VA_Mul -> arithInstr VMUL + VA_Div -> arithInstr VDIV + where + -- opcode src2 src1 dst <==> dst = src1 `opcode` src2 + arithInstr instr = exp1 `appOL` exp2 `snocOL` + (instr format (OpReg reg2) reg1 dst) + return (Any format code) + + vector_float_op_sse :: VectorArithInstns + -> Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_op_sse op l w expr1 expr2 = do + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let format = case w of + W32 -> VecFormat l FmtFloat W32 + W64 -> VecFormat l FmtDouble W64 + _ -> pprPanic "Operation not supported for width " (ppr w) + code dst = case op of + VA_Add -> arithInstr ADD + VA_Sub -> arithInstr SUB + VA_Mul -> arithInstr MUL + VA_Div -> arithInstr FDIV + where + -- opcode src2 src1 <==> src1 = src1 `opcode` src2 + arithInstr instr + = exp1 `appOL` exp2 `snocOL` + (MOVU format (OpReg reg1) (OpReg dst)) `snocOL` + (instr format (OpReg reg2) (OpReg dst)) + return (Any format code) -------------------- + vector_float_unpack :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_unpack l W32 expr (CmmLit lit) + = do + (r, exp) <- getSomeReg expr + let format = VecFormat l FmtFloat W32 + imm = litToImm lit + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` (VMOVU format (OpReg r) (OpReg dst)) + CmmInt _ _ -> exp `snocOL` (VPSHUFD format (OpImm imm) (OpReg r) dst) + _ -> panic "Error in offset while unpacking" + return (Any format code) + vector_float_unpack l W64 expr (CmmLit lit) + = do + dflags <- getDynFlags + (r, exp) <- getSomeReg expr + let format = VecFormat l FmtDouble W64 + addr = spRel dflags 0 + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` + (MOVL format (OpReg r) (OpAddr addr)) `snocOL` + (MOV FF64 (OpAddr addr) (OpReg dst)) + CmmInt 1 _ -> exp `snocOL` + (MOVH format (OpReg r) (OpAddr addr)) `snocOL` + (MOV FF64 (OpAddr addr) (OpReg dst)) + _ -> panic "Error in offset while unpacking" + return (Any format code) + vector_float_unpack _ w c e + = pprPanic "Unpack not supported for : " (ppr c $$ ppr e $$ ppr w) + ----------------------- + + vector_float_unpack_sse :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_unpack_sse l W32 expr (CmmLit lit) + = do + (r,exp) <- getSomeReg expr + let format = VecFormat l FmtFloat W32 + imm = litToImm lit + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst)) + CmmInt _ _ -> exp `snocOL` (PSHUFD format (OpImm imm) (OpReg r) dst) + _ -> panic "Error in offset while unpacking" + return (Any format code) + vector_float_unpack_sse _ w c e + = pprPanic "Unpack not supported for : " (ppr c $$ ppr e $$ ppr w) + ----------------------- + vector_float_broadcast_avx :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_broadcast_avx len W32 expr1 expr2 + = do + dflags <- getDynFlags + fn <- getAnyReg expr1 + (r', exp) <- getSomeReg expr2 + let f = VecFormat len FmtFloat W32 + addr = spRel dflags 0 + in return $ Any f (\r -> exp `appOL` + (fn r) `snocOL` + (MOVU f (OpReg r') (OpAddr addr)) `snocOL` + (VBROADCAST f addr r)) + vector_float_broadcast_avx len W64 expr1 expr2 + = do + dflags <- getDynFlags + fn <- getAnyReg expr1 + (r', exp) <- getSomeReg expr2 + let f = VecFormat len FmtDouble W64 + addr = spRel dflags 0 + in return $ Any f (\r -> exp `appOL` + (fn r) `snocOL` + (MOVU f (OpReg r') (OpAddr addr)) `snocOL` + (MOVL f (OpAddr addr) (OpReg r)) `snocOL` + (MOVH f (OpAddr addr) (OpReg r))) + vector_float_broadcast_avx _ _ c _ + = pprPanic "Broadcast not supported for : " (ppr c) + ----------------------- + vector_float_broadcast_sse :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_broadcast_sse len W32 expr1 expr2 + = do + dflags <- getDynFlags + fn <- getAnyReg expr1 -- destination + (r, exp) <- getSomeReg expr2 -- source + let f = VecFormat len FmtFloat W32 + addr = spRel dflags 0 + code dst = exp `appOL` + (fn dst) `snocOL` + (MOVU f (OpReg r) (OpAddr addr)) `snocOL` + (insertps 0) `snocOL` + (insertps 16) `snocOL` + (insertps 32) `snocOL` + (insertps 48) + where + insertps off = + INSERTPS f (OpImm $ litToImm $ CmmInt off W32) (OpAddr addr) dst + + in return $ Any f code + vector_float_broadcast_sse _ _ c _ + = pprPanic "Broadcast not supported for : " (ppr c) + ----------------------- sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register sub_code rep x (CmmLit (CmmInt y _)) | is32BitInteger (-y) = add_int rep x (-y) @@ -983,6 +1326,21 @@ return (Fixed format result code) +getRegister' _ _ (CmmLoad mem pk) + | isVecType pk = do + use_avx <- avxEnabled + use_sse <- sseEnabled + Amode addr mem_code <- getAmode mem + let format = cmmTypeFormat pk + code dst + | use_avx = mem_code `snocOL` + VMOVU format (OpAddr addr) (OpReg dst) + | use_sse = mem_code `snocOL` + MOVU format (OpAddr addr) (OpReg dst) + | otherwise = pprPanic (unlines ["avx or sse flag not enabled", + "for loading to "]) + (ppr pk) + return (Any format code) getRegister' _ _ (CmmLoad mem pk) | isFloatType pk @@ -1049,10 +1407,24 @@ -- small memory model (see gcc docs, -mcmodel=small). getRegister' dflags _ (CmmLit lit) - = do let format = cmmTypeFormat (cmmLitType dflags lit) - imm = litToImm lit - code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) - return (Any format code) + | isVecType cmmtype = vectorRegister cmmtype + | otherwise = standardRegister cmmtype + where + cmmtype = cmmLitType dflags lit + vectorRegister ctype + = do + --NOTE: + -- This operation is only used to zero a register. For loading a + -- vector literal there are pack and broadcast operations + let format = cmmTypeFormat ctype + code dst = unitOL (XOR format (OpReg dst) (OpReg dst)) + return (Any format code) + standardRegister ctype + = do + let format = cmmTypeFormat ctype + imm = litToImm lit + code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) + return (Any format code) getRegister' _ _ other | isVecExpr other = needLlvm @@ -1118,8 +1490,14 @@ return (reg, code) reg2reg :: Format -> Reg -> Reg -> Instr -reg2reg format src dst = MOV format (OpReg src) (OpReg dst) - +reg2reg format@(VecFormat _ FmtFloat W32) src dst + = VMOVU format (OpReg src) (OpReg dst) +reg2reg format@(VecFormat _ FmtDouble W64) src dst + = VMOVU format (OpReg src) (OpReg dst) +reg2reg (VecFormat _ _ _) _ _ + = panic "MOV operation not implemented for vectors" +reg2reg format src dst + = MOV format (OpReg src) (OpReg dst) -------------------------------------------------------------------------------- getAmode :: CmmExpr -> NatM Amode @@ -1181,6 +1559,9 @@ getAmode' _ (CmmMachOp (MO_Add _) [x,y]) = x86_complex_amode x y 0 0 +getAmode' _ (CmmLit lit@(CmmFloat _ w)) + = memConstant (mkAlignment $ widthInBytes w) lit + getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit = return (Amode (ImmAddr (litToImm lit) 0) nilOL) @@ -1561,7 +1942,8 @@ assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - +assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_VecCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -- integer assignment to memory -- specific case of adding/subtracting an integer to a particular address. @@ -1638,7 +2020,30 @@ let platform = targetPlatform dflags return (src_code (getRegisterReg platform reg)) +assignMem_VecCode pk addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + use_avx <- avxEnabled + use_sse <- sseEnabled + let + code | use_avx = src_code `appOL` + addr_code `snocOL` + (VMOVU pk (OpReg src_reg) (OpAddr addr)) + | use_sse = src_code `appOL` + addr_code `snocOL` + (MOVU pk (OpReg src_reg) (OpAddr addr)) + | otherwise = sorry "Please enable the -mavx or -msse flag" + return code +assignReg_VecCode format reg src = do + use_avx <- avxEnabled + use_sse <- sseEnabled + src_code <- getAnyReg src + dflags <- getDynFlags + let platform = targetPlatform dflags + flag = use_avx || use_sse + return (src_code (getVecRegisterReg platform flag format reg)) + genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock genJump (CmmLoad mem _) regs = do @@ -1891,8 +2296,9 @@ possibleWidth = minimum [left, sizeBytes] dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) +genCCall _ _ (PrimTarget MO_ReadBarrier) _ _ _ = return nilOL genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; + -- barriers compile to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL @@ -2875,7 +3281,9 @@ MO_F32_Cos -> fsLit "cosf" MO_F32_Tan -> fsLit "tanf" MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" MO_F32_Asin -> fsLit "asinf" MO_F32_Acos -> fsLit "acosf" @@ -2896,7 +3304,9 @@ MO_F64_Cos -> fsLit "cos" MO_F64_Tan -> fsLit "tan" MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" MO_F64_Asin -> fsLit "asin" MO_F64_Acos -> fsLit "acos" @@ -2944,6 +3354,7 @@ MO_AddWordC {} -> unsupported MO_SubWordC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported (MO_Prefetch_Data _ ) -> unsupported @@ -3356,6 +3767,7 @@ x@II16 -> wrongFmt x x@II32 -> wrongFmt x x@II64 -> wrongFmt x + x@VecFormat {} -> wrongFmt x where wrongFmt x = panic $ "sse2NegCode: " ++ show x @@ -3370,28 +3782,32 @@ return (Any fmt code) isVecExpr :: CmmExpr -> Bool -isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True -isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True -isVecExpr (CmmMachOp (MO_V_Add {}) _) = True -isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True -isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True -isVecExpr (CmmMachOp _ [e]) = isVecExpr e -isVecExpr _ = False +isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True +isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True +isVecExpr (CmmMachOp (MO_V_Add {}) _) = True +isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True +isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Broadcast {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True +isVecExpr (CmmMachOp _ [e]) = isVecExpr e +isVecExpr _ = False needLlvm :: NatM a needLlvm = sorry $ unlines ["The native code generator does not support vector" ,"instructions. Please use -fllvm."] + +incorrectOperands :: NatM a +incorrectOperands = sorry "Incorrect number of operands" -- | This works on the invariant that all jumps in the given blocks are required. -- Starting from there we try to make a few more jumps redundant by reordering diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -34,7 +34,7 @@ import Cmm import FastString import Outputable -import Platform +import GHC.Platform import BasicTypes (Alignment) import CLabel @@ -328,6 +328,36 @@ | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit | MFENCE + -- Vector Instructions -- + -- NOTE: Instructions follow the AT&T syntax + -- Constructors and deconstructors + | VBROADCAST Format AddrMode Reg + | VEXTRACT Format Operand Reg Operand + | INSERTPS Format Operand Operand Reg + + -- move operations + | VMOVU Format Operand Operand + | MOVU Format Operand Operand + | MOVL Format Operand Operand + | MOVH Format Operand Operand + + -- logic operations + | VPXOR Format Reg Reg Reg + + -- Arithmetic + | VADD Format Operand Reg Reg + | VSUB Format Operand Reg Reg + | VMUL Format Operand Reg Reg + | VDIV Format Operand Reg Reg + + -- Shuffle + | VPSHUFD Format Operand Operand Reg + | PSHUFD Format Operand Operand Reg + + -- Shift + | PSLLDQ Format Operand Reg + | PSRLDQ Format Operand Reg + data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 @@ -430,6 +460,31 @@ CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) MFENCE -> noUsage + -- vector instructions + VBROADCAST _ src dst -> mkRU (use_EA src []) [dst] + VEXTRACT _ off src dst -> mkRU ((use_R off []) ++ [src]) (use_R dst []) + INSERTPS _ off src dst + -> mkRU ((use_R off []) ++ (use_R src []) ++ [dst]) [dst] + + VMOVU _ src dst -> mkRU (use_R src []) (use_R dst []) + MOVU _ src dst -> mkRU (use_R src []) (use_R dst []) + MOVL _ src dst -> mkRU (use_R src []) (use_R dst []) + MOVH _ src dst -> mkRU (use_R src []) (use_R dst []) + VPXOR _ s1 s2 dst -> mkRU [s1,s2] [dst] + + VADD _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst] + VSUB _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst] + VMUL _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst] + VDIV _ s1 s2 dst -> mkRU ((use_R s1 []) ++ [s2]) [dst] + + VPSHUFD _ off src dst + -> mkRU (concatMap (\op -> use_R op []) [off, src]) [dst] + PSHUFD _ off src dst + -> mkRU (concatMap (\op -> use_R op []) [off, src]) [dst] + + PSLLDQ _ off dst -> mkRU (use_R off []) [dst] + PSRLDQ _ off dst -> mkRU (use_R off []) [dst] + _other -> panic "regUsage: unrecognised instr" where -- # Definitions @@ -588,6 +643,32 @@ CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst MFENCE -> instr + -- vector instructions + VBROADCAST fmt src dst -> VBROADCAST fmt (lookupAddr src) (env dst) + VEXTRACT fmt off src dst + -> VEXTRACT fmt (patchOp off) (env src) (patchOp dst) + INSERTPS fmt off src dst + -> INSERTPS fmt (patchOp off) (patchOp src) (env dst) + + VMOVU fmt src dst -> VMOVU fmt (patchOp src) (patchOp dst) + MOVU fmt src dst -> MOVU fmt (patchOp src) (patchOp dst) + MOVL fmt src dst -> MOVL fmt (patchOp src) (patchOp dst) + MOVH fmt src dst -> MOVH fmt (patchOp src) (patchOp dst) + VPXOR fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst) + + VADD fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst) + VSUB fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst) + VMUL fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst) + VDIV fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst) + + VPSHUFD fmt off src dst + -> VPSHUFD fmt (patchOp off) (patchOp src) (env dst) + PSHUFD fmt off src dst + -> PSHUFD fmt (patchOp off) (patchOp src) (env dst) + PSLLDQ fmt off dst + -> PSLLDQ fmt (patchOp off) (env dst) + PSRLDQ fmt off dst + -> PSRLDQ fmt (patchOp off) (env dst) _other -> panic "patchRegs: unrecognised instr" where diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -41,8 +41,7 @@ import Cmm hiding (topInfoTable) import BlockId import CLabel -import Unique ( pprUniqueAlways ) -import Platform +import GHC.Platform import FastString import Outputable @@ -280,10 +279,7 @@ if target32Bit platform then ppr32_reg_no f i else ppr64_reg_no f i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u - RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u - RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + RegVirtual v -> ppr v where ppr32_reg_no :: Format -> Int -> SDoc @@ -395,6 +391,11 @@ II64 -> sLit "q" FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) + + VecFormat _ FmtFloat W32 -> sLit "ps" + VecFormat _ FmtDouble W64 -> sLit "pd" + -- TODO: Add Ints and remove panic + VecFormat {} -> panic "Incorrect width" ) pprFormat_x87 :: Format -> SDoc @@ -783,6 +784,41 @@ pprInstr (DIV fmt op) = pprFormatOp (sLit "div") fmt op pprInstr (IMUL2 fmt op) = pprFormatOp (sLit "imul") fmt op +-- Vector Instructions + +pprInstr (VADD format s1 s2 dst) + = pprFormatOpRegReg (sLit "vadd") format s1 s2 dst +pprInstr (VSUB format s1 s2 dst) + = pprFormatOpRegReg (sLit "vsub") format s1 s2 dst +pprInstr (VMUL format s1 s2 dst) + = pprFormatOpRegReg (sLit "vmul") format s1 s2 dst +pprInstr (VDIV format s1 s2 dst) + = pprFormatOpRegReg (sLit "vdiv") format s1 s2 dst +pprInstr (VBROADCAST format from to) + = pprBroadcast (sLit "vbroadcast") format from to +pprInstr (VMOVU format from to) + = pprFormatOpOp (sLit "vmovu") format from to +pprInstr (MOVU format from to) + = pprFormatOpOp (sLit "movu") format from to +pprInstr (MOVL format from to) + = pprFormatOpOp (sLit "movl") format from to +pprInstr (MOVH format from to) + = pprFormatOpOp (sLit "movh") format from to +pprInstr (VPXOR format s1 s2 dst) + = pprXor (sLit "vpxor") format s1 s2 dst +pprInstr (VEXTRACT format offset from to) + = pprFormatOpRegOp (sLit "vextract") format offset from to +pprInstr (INSERTPS format offset addr dst) + = pprInsert (sLit "insertps") format offset addr dst +pprInstr (VPSHUFD format offset src dst) + = pprShuf (sLit "vpshufd") format offset src dst +pprInstr (PSHUFD format offset src dst) + = pprShuf (sLit "pshufd") format offset src dst +pprInstr (PSLLDQ format offset dst) + = pprShiftLeft (sLit "pslldq") format offset dst +pprInstr (PSRLDQ format offset dst) + = pprShiftRight (sLit "psrldq") format offset dst + -- x86_64 only pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2 pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op @@ -875,7 +911,24 @@ pprMnemonic name format = char '\t' <> ptext name <> pprFormat format <> space +pprGenMnemonic :: PtrString -> Format -> SDoc +pprGenMnemonic name _ = + char '\t' <> ptext name <> ptext (sLit "") <> space +pprBroadcastMnemonic :: PtrString -> Format -> SDoc +pprBroadcastMnemonic name format = + char '\t' <> ptext name <> pprBroadcastFormat format <> space + +pprBroadcastFormat :: Format -> SDoc +pprBroadcastFormat x + = ptext (case x of + VecFormat _ FmtFloat W32 -> sLit "ss" + VecFormat _ FmtDouble W64 -> sLit "sd" + -- TODO: Add Ints and remove panic + VecFormat {} -> panic "Incorrect width" + _ -> panic "Scalar Format invading vector operation" + ) + pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc pprFormatImmOp name format imm op1 = hcat [ @@ -921,7 +974,16 @@ pprOperand format op2 ] - +pprFormatOpRegOp :: PtrString -> Format -> Operand -> Reg -> Operand -> SDoc +pprFormatOpRegOp name format off reg1 op2 + = hcat [ + pprMnemonic name format, + pprOperand format off, + comma, + pprReg format reg1, + comma, + pprOperand format op2 + ] pprRegReg :: PtrString -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2 @@ -944,6 +1006,17 @@ pprReg (archWordFormat (target32Bit platform)) reg2 ] +pprFormatOpRegReg :: PtrString -> Format -> Operand -> Reg -> Reg -> SDoc +pprFormatOpRegReg name format op1 reg2 reg3 + = hcat [ + pprMnemonic name format, + pprOperand format op1, + comma, + pprReg format reg2, + comma, + pprReg format reg3 + ] + pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc pprCondOpReg name format cond op1 reg2 = hcat [ @@ -1008,3 +1081,68 @@ pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] + + +-- Custom pretty printers +-- These instructions currently don't follow a uniform suffix pattern +-- in their names, so we have custom pretty printers for them. + +pprBroadcast :: PtrString -> Format -> AddrMode -> Reg -> SDoc +pprBroadcast name format op dst + = hcat [ + pprBroadcastMnemonic name format, + pprAddr op, + comma, + pprReg format dst + ] + +pprXor :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc +pprXor name format reg1 reg2 reg3 + = hcat [ + pprGenMnemonic name format, + pprReg format reg1, + comma, + pprReg format reg2, + comma, + pprReg format reg3 + ] + +pprInsert :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc +pprInsert name format off src dst + = hcat [ + pprGenMnemonic name format, + pprOperand format off, + comma, + pprOperand format src, + comma, + pprReg format dst + ] + +pprShuf :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc +pprShuf name format op1 op2 reg3 + = hcat [ + pprGenMnemonic name format, + pprOperand format op1, + comma, + pprOperand format op2, + comma, + pprReg format reg3 + ] + +pprShiftLeft :: PtrString -> Format -> Operand -> Reg -> SDoc +pprShiftLeft name format off reg + = hcat [ + pprGenMnemonic name format, + pprOperand format off, + comma, + pprReg format reg + ] + +pprShiftRight :: PtrString -> Format -> Operand -> Reg -> SDoc +pprShiftRight name format off reg + = hcat [ + pprGenMnemonic name format, + pprOperand format off, + comma, + pprReg format reg + ] diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -15,13 +15,15 @@ import Reg import Outputable -import Platform +import GHC.Platform import Unique import UniqFM import X86.Regs +--TODO: +-- Add VirtualRegAVX and inspect VecFormat and allocate mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format = case format of @@ -31,6 +33,7 @@ -- For now we map both to being allocated as "Double" Registers -- on X86/X86_64 FF64 -> VirtualRegD u + VecFormat {} -> VirtualRegVec u _other -> VirtualRegI u regDotColor :: Platform -> RealReg -> SDoc diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -60,7 +60,7 @@ import CLabel ( CLabel ) import DynFlags import Outputable -import Platform +import GHC.Platform import qualified Data.Array as A @@ -84,6 +84,7 @@ -> case vr of VirtualRegD{} -> 1 VirtualRegF{} -> 0 + VirtualRegVec{} -> 1 _other -> 0 diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -131,6 +131,7 @@ , map idName wiredInIds , map (idName . primOpId) allThePrimOps + , map (idName . primOpWrapperId) allThePrimOps , basicKnownKeyNames , templateHaskellNames ] @@ -214,7 +215,8 @@ knownNamesInfo = unitNameEnv coercibleTyConName $ vcat [ text "Coercible is a special constraint with custom solving rules." , text "It is not a class." - , text "Please see section 9.14.4 of the user's guide for details." ] + , text "Please see section `The Coercible constraint`" + , text "of the user's guide for details." ] {- We let a lot of "non-standard" values be visible, so that we can make diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -68,6 +68,7 @@ import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..)) import SrcLoc import Outputable +import UniqSet ( uniqSetAny ) import Util import Maybes import DynFlags @@ -1462,7 +1463,9 @@ RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) LocalBindCtxt ns -> lookup_group ns ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt ns -> lookup_top (`elemNameSet` ns) + InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 + then return (Right $ mkUnboundNameRdr rdr_name) + else lookup_top (`elemNameSet` ns) where lookup_cls_op cls = lookupSubBndrOcc True cls doc rdr_name diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -208,7 +208,7 @@ ------------------------------------------ -- Template Haskell extensions --- Don't ifdef-GHCI them because we want to fail gracefully +-- Don't ifdef-HAVE_INTERPRETER them because we want to fail gracefully -- (not with an rnExpr crash) in a stage-1 compiler. rnExpr e@(HsBracket _ br_body) = rnBracket e br_body diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -16,6 +16,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -72,7 +73,7 @@ import DataCon import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( when, liftM, ap, guard ) +import Control.Monad ( when, ap, guard ) import qualified Data.List.NonEmpty as NE import Data.Ratio @@ -107,10 +108,8 @@ newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars) } + deriving (Functor) -- See Note [CpsRn monad] - -instance Functor CpsRn where - fmap = liftM instance Applicative CpsRn where pure x = CpsRn (\k -> k x) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -69,7 +69,7 @@ import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( isNothing, fromMaybe ) +import Data.Maybe ( isNothing, isJust, fromMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) {- | @rnSourceDecl@ "renames" declarations. @@ -1539,18 +1539,22 @@ -- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl -rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, tcdDataDefn = defn }) +rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = + panic "rnTyClDecl: DataDecl with XHsDataDefn" +rnTyClDecl (DataDecl + { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data + , dd_kindSig = kind_sig} }) = do { tycon' <- lookupLocatedTopBndrRn tycon ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> do { (defn', fvs) <- rnDataDefn doc defn - -- See Note [Complete user-supplied kind signatures] in HsDecls - ; cusks_enabled <- xoptM LangExt.CUSKs - ; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs - rn_info = DataDeclRn { tcdDataCusk = cusk + ; cusk <- dataDeclHasCUSK + tyvars' new_or_data no_rhs_kvs (isJust kind_sig) + ; let rn_info = DataDeclRn { tcdDataCusk = cusk , tcdFVs = fvs } ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) ; return (DataDecl { tcdLName = tycon' @@ -1625,6 +1629,42 @@ cls_doc = ClassDeclCtx lcls rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl" + +-- Does the data type declaration include a CUSK? +dataDeclHasCUSK :: LHsQTyVars pass -> NewOrData -> Bool -> Bool -> RnM Bool +dataDeclHasCUSK tyvars new_or_data no_rhs_kvs has_kind_sig = do + { -- See Note [Unlifted Newtypes and CUSKs], and for a broader + -- picture, see Note [Implementation of UnliftedNewtypes]. + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let non_cusk_newtype + | NewType <- new_or_data = + unlifted_newtypes && not has_kind_sig + | otherwise = False + -- See Note [CUSKs: complete user-supplied kind signatures] in HsDecls + ; cusks_enabled <- xoptM LangExt.CUSKs + ; return $ cusks_enabled && hsTvbAllKinded tyvars && + no_rhs_kvs && not non_cusk_newtype + } + +{- Note [Unlifted Newtypes and CUSKs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unlifted newtypes are enabled, a newtype must have a kind signature +in order to be considered have a CUSK. This is because the flow of +kind inference works differently. Consider: + + newtype Foo = FooC Int + +When UnliftedNewtypes is disabled, we decide that Foo has kind +`TYPE 'LiftedRep` without looking inside the data constructor. So, we +can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, +we fill in the kind of Foo as a metavar that gets solved by unification +with the kind of the field inside FooC (that is, Int, whose kind is +`TYPE 'LiftedRep`). But since we have to look inside the data constructors +to figure out the kind signature of Foo, it does not have a CUSK. + +See Note [Implementation of UnliftedNewtypes] for where this fits in to +the broader picture of UnliftedNewtypes. +-} -- "type" and "type instance" declarations rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -378,22 +378,19 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr) - = do { checkTH expr "Template Haskell typed splice" - ; loc <- getSrcSpanM + = do { loc <- getSrcSpanM ; n' <- newLocalBndrRn (cL loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) - = do { checkTH expr "Template Haskell untyped splice" - ; loc <- getSrcSpanM + = do { loc <- getSrcSpanM ; n' <- newLocalBndrRn (cL loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) - = do { checkTH quoter "Template Haskell quasi-quote" - ; loc <- getSrcSpanM + = do { loc <- getSrcSpanM ; splice_name' <- newLocalBndrRn (cL loc splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -693,8 +693,8 @@ | otherwise = case rtke_what env of RnTypeBody -> Nothing - RnConstraint -> Just constraint_msg RnTopConstraint -> Just constraint_msg + RnConstraint -> Just constraint_msg constraint_msg = hang (notAllowed pprAnonWildCard <+> text "in a constraint") @@ -714,7 +714,10 @@ | otherwise = case rtke_what env of RnTypeBody -> Nothing -- Allowed - RnTopConstraint -> Nothing -- Allowed + RnTopConstraint -> Nothing -- Allowed; e.g. + -- f :: (Eq _a) => _a -> Int + -- g :: (_a, _b) => T _a _b -> Int + -- The named tyvars get filled in from elsewhere RnConstraint -> Just constraint_msg constraint_msg = notAllowed (ppr name) <+> text "in a constraint" diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -462,7 +462,7 @@ doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = runCorePasses passes -#if defined(GHCI) +#if defined(HAVE_INTERPRETER) doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass #else doCorePass pass@CoreDoPluginPass {} = pprPanic "doCorePass" (ppr pass) diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -4,6 +4,7 @@ \section[SimplMonad]{The simplifier Monad} -} +{-# LANGUAGE DeriveFunctor #-} module SimplMonad ( -- The monad SimplM, @@ -37,7 +38,7 @@ import ErrUtils as Err import Panic (throwGhcExceptionIO, GhcException (..)) import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf ) -import Control.Monad ( liftM, ap ) +import Control.Monad ( ap ) {- ************************************************************************ @@ -57,6 +58,7 @@ -> SimplCount -> IO (result, UniqSupply, SimplCount)} -- we only need IO here for dump output + deriving (Functor) data SimplTopEnv = STE { st_flags :: DynFlags @@ -103,9 +105,6 @@ {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} - -instance Functor SimplM where - fmap = liftM instance Applicative SimplM where pure = returnSmpl diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} module Specialise ( specProgram, specUnfolding ) where @@ -938,7 +939,7 @@ | otherwise = return () where allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - doWarn reason = + doWarn reason = warnMsg reason (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) @@ -2530,16 +2531,13 @@ ************************************************************************ -} -newtype SpecM a = SpecM (State SpecState a) +newtype SpecM a = SpecM (State SpecState a) deriving (Functor) data SpecState = SpecState { spec_uniq_supply :: UniqSupply, spec_module :: Module, spec_dflags :: DynFlags } - -instance Functor SpecM where - fmap = liftM instance Applicative SpecM where pure x = SpecM $ return x diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, DeriveFunctor #-} -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -45,12 +45,12 @@ import DynFlags import ForeignCall import Demand ( isUsedOnce ) -import PrimOp ( PrimCall(..) ) +import PrimOp ( PrimCall(..), primOpWrapperId ) import SrcLoc ( mkGeneralSrcSpan ) import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe (fromMaybe) -import Control.Monad (liftM, ap) +import Control.Monad (ap) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -268,7 +268,7 @@ bind = StgTopLifted $ StgNonRec id stg_rhs in - ASSERT2(consistentCafInfo id bind, ppr id ) + assertConsistentCaInfo dflags id bind (ppr bind) -- NB: previously the assertion printed 'rhs' and 'bind' -- as well as 'id', but that led to a black hole -- where printing the assertion error tripped the @@ -296,9 +296,18 @@ bind = StgTopLifted $ StgRec (zip binders stg_rhss) in - ASSERT2(consistentCafInfo (head binders) bind, ppr binders) + assertConsistentCaInfo dflags (head binders) bind (ppr binders) (env', ccs', bind) +-- | CAF consistency issues will generally result in segfaults and are quite +-- difficult to debug (see #16846). We enable checking of the +-- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that +-- we catch these issues. +assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a +assertConsistentCaInfo dflags id bind err_doc result + | gopt Opt_DoStgLinting dflags || debugIsOn + , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc + | otherwise = result -- Assertion helper: this checks that the CafInfo on the Id matches -- what CoreToStg has figured out about the binding's SRT. The @@ -528,8 +537,12 @@ (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) -- Some primitive operator that might be implemented as a library call. - PrimOpId op -> ASSERT( saturated ) - StgOpApp (StgPrimOp op) args' res_ty + -- As described in Note [Primop wrappers] in PrimOp.hs, here we + -- turn unsaturated primop applications into applications of + -- the primop's wrapper. + PrimOpId op + | saturated -> StgOpApp (StgPrimOp op) args' res_ty + | otherwise -> StgApp (primOpWrapperId op) args' -- A call to some primitive Cmm function. FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) @@ -539,7 +552,7 @@ -- A regular foreign call. FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + StgOpApp (StgFCallOp call (idType f)) args' res_ty TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' @@ -813,6 +826,7 @@ { unCtsM :: IdEnv HowBound -> a } + deriving (Functor) data HowBound = ImportBound -- Used only as a response to lookupBinding; never @@ -860,9 +874,6 @@ thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b thenCts m k = CtsM $ \env -> unCtsM (k (unCtsM m env)) env - -instance Functor CtsM where - fmap = liftM instance Applicative CtsM where pure = returnCts diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -32,7 +32,8 @@ basic properties listed above. -} -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, + DeriveFunctor #-} module StgLint ( lintStgTopBindings ) where @@ -258,6 +259,7 @@ -> Bag MsgDoc -- Error messages so far -> (a, Bag MsgDoc) -- Result and error messages (if any) } + deriving (Functor) data LintFlags = LintFlags { lf_unarised :: !Bool -- ^ have we run the unariser yet? @@ -292,9 +294,6 @@ Nothing else Just (vcat (punctuate blankLine (bagToList errs))) - -instance Functor LintM where - fmap = liftM instance Applicative LintM where pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs) diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -76,13 +76,12 @@ import Module ( Module ) import Outputable import Packages ( isDllName ) -import Platform +import GHC.Platform import PprCore ( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) import TyCon ( PrimRep(..), TyCon ) import Type ( Type ) import RepType ( typePrimRep1 ) -import Unique ( Unique ) import Util import Data.List.NonEmpty ( NonEmpty, toList ) @@ -686,10 +685,11 @@ | StgPrimCallOp PrimCall - | StgFCallOp ForeignCall Unique - -- The Unique is occasionally needed by the C pretty-printer - -- (which lacks a unique supply), notably when generating a - -- typedef for foreign-export-dynamic + | StgFCallOp ForeignCall Type + -- The Type, which is obtained from the foreign import declaration + -- itself, is needed by the stg-to-cmm pass to determine the offset to + -- apply to unlifted boxed arguments in StgCmmForeign. See Note + -- [Unlifted boxed arguments to foreign calls] {- ************************************************************************ diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs --- a/compiler/typecheck/ClsInst.hs +++ b/compiler/typecheck/ClsInst.hs @@ -16,6 +16,7 @@ import TcType import TcMType import TcEvidence +import TcTypeableValidity import RnEnv( addUsedGRE ) import RdrName( lookupGRE_FieldLabel ) import InstEnv @@ -432,7 +433,7 @@ -- of monomorphic kind (e.g. all kind variables have been instantiated). doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args - | Just _ <- tyConRepName_maybe tc + | tyConIsTypeable tc = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args) , cir_mk_ev = mk_ev , cir_what = BuiltinInstance } diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -297,23 +297,22 @@ -- If they don't match, emit a kind-equality to promise that they will -- eventually do so, and thus make a kind-homongeneous substitution. instTyVarsWith orig tvs tys - = go empty_subst tvs tys + = go emptyTCvSubst tvs tys where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) - go subst [] [] = return subst go subst (tv:tvs) (ty:tys) | tv_kind `tcEqType` ty_kind - = go (extendTCvSubst subst tv ty) tvs tys + = go (extendTvSubstAndInScope subst tv ty) tvs tys | otherwise = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind - ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys } + ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } where tv_kind = substTy subst (tyVarKind tv) ty_kind = tcTypeKind ty go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) + {- ************************************************************************ diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -28,7 +28,7 @@ -- Some platforms don't support the external interpreter, and -- compilation on those platforms shouldn't fail just due to -- annotations -#ifndef GHCI +#if !defined(HAVE_INTERNAL_INTERPRETER) tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations anns = do dflags <- getDynFlags diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1020,7 +1020,7 @@ ; case tcGetCastedTyVar_maybe wc_var_ty of -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it - -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to + -- comes from the checkExpectedKind in TcHsType.tcAnonWildCardOcc. So, to -- make the kinds work out, we reverse the cast here. Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} module TcCanonical( canonicalize, @@ -1006,8 +1007,10 @@ = do { let tv2 = binderVar bndr2 ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv) (substTy subst (tyVarKind tv2)) - ; let subst' = extendTvSubst subst tv2 + ; let subst' = extendTvSubstAndInScope subst tv2 (mkCastTy (mkTyVarTy skol_tv) kind_co) + -- skol_tv is already in the in-scope set, but the + -- free vars of kind_co are not; hence "...AndInScope" ; (co, wanteds2) <- go skol_tvs subst' bndrs2 ; return ( mkTcForAllCo skol_tv kind_co co , wanteds1 `unionBags` wanteds2 ) } @@ -2079,13 +2082,6 @@ where k1 and k2 differ? This Note explores this treacherous area. -First off, the question above is slightly the wrong question. Flattening -a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening -the kind might introduce a cast. So we might have a casted tyvar on the -left. We thus revise our test case to - - (tv |> co :: k1) ~ (rhs :: k2) - We must proceed differently here depending on whether we have a Wanted or a Given. Consider this: @@ -2109,36 +2105,33 @@ Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the new `co` is a Wanted. - The solution is then not to use `co` to "rewrite" -- that is, cast - -- `w`, but instead to keep `w` heterogeneous and - irreducible. Given that we're not using `co`, there is no reason to - collect evidence for it, so `co` is born a Derived, with a CtOrigin - of KindEqOrigin. +The solution is then not to use `co` to "rewrite" -- that is, cast -- `w`, but +instead to keep `w` heterogeneous and irreducible. Given that we're not using +`co`, there is no reason to collect evidence for it, so `co` is born a +Derived, with a CtOrigin of KindEqOrigin. When the Derived is solved (by +unification), the original wanted (`w`) will get kicked out. We thus get -When the Derived is solved (by unification), the original wanted (`w`) -will get kicked out. +[D] _ :: k ~ Type +[W] w :: (alpha :: k) ~ (Int :: Type) -Note that, if we had [G] co1 :: k ~ Type available, then none of this code would -trigger, because flattening would have rewritten k to Type. That is, -`w` would look like [W] (alpha |> co1 :: Type) ~ (Int :: Type), and the tyvar -case will trigger, correctly rewriting alpha to (Int |> sym co1). +Note that the Wanted is unchanged and will be irreducible. This all happens +in canEqTyVarHetero. +Note that, if we had [G] co1 :: k ~ Type available, then we never get +to canEqTyVarHetero: canEqTyVar tries flattening the kinds first. If +we have [G] co1 :: k ~ Type, then flattening the kind of alpha would +rewrite k to Type, and we would end up in canEqTyVarHomo. + Successive canonicalizations of the same Wanted may produce duplicate Deriveds. Similar duplications can happen with fundeps, and there seems to be no easy way to avoid. I expect this case to be rare. -For Givens, this problem doesn't bite, so a heterogeneous Given gives +For Givens, this problem (the Wanteds-rewriting-Wanteds action of +a kind coercion) doesn't bite, so a heterogeneous Given gives rise to a Given kind equality. No Deriveds here. We thus homogenise -the Given (see the "homo_co" in the Given case in canEqTyVar) and +the Given (see the "homo_co" in the Given case in canEqTyVarHetero) and carry on with a homogeneous equality constraint. -Separately, I (Richard E) spent some time pondering what to do in the case -that we have [W] (tv |> co1 :: k1) ~ (tv |> co2 :: k2) where k1 and k2 -differ. Note that the tv is the same. (This case is handled as the first -case in canEqTyVarHomo.) At one point, I thought we could solve this limited -form of heterogeneous Wanted, but I then reconsidered and now treat this case -just like any other heterogeneous Wanted. - Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat type synonym applications as xi types, that is, they do not @@ -2198,10 +2191,7 @@ | Stop CtEvidence -- The (rewritten) constraint was solved SDoc -- Tells how it was solved -- Any new sub-goals have been put on the work list - -instance Functor StopOrContinue where - fmap f (ContinueWith x) = ContinueWith (f x) - fmap _ (Stop ev s) = Stop ev s + deriving (Functor) instance Outputable a => Outputable (StopOrContinue a) where ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev @@ -2285,8 +2275,12 @@ (mkTcSymCo co)) rewriteEvidence ev@(CtWanted { ctev_dest = dest + , ctev_nosh = si , ctev_loc = loc }) new_pred co - = do { mb_new_ev <- newWanted loc new_pred + = do { mb_new_ev <- newWanted_SI si loc new_pred + -- The "_SI" varant ensures that we make a new Wanted + -- with the same shadow-info as the existing one + -- with the same shadow-info as the existing one (#16735) ; MASSERT( tcCoercionRole co == ctEvRole ev ) ; setWantedEvTerm dest (mkEvCast (getEvExpr mb_new_ev) @@ -2334,8 +2328,10 @@ `mkTcTransCo` mkTcSymCo rhs_co) ; newGivenEvVar loc' (new_pred, new_tm) } - | CtWanted { ctev_dest = dest } <- old_ev - = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs + | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev + = do { (new_ev, hole_co) <- newWantedEq_SI si loc' (ctEvRole old_ev) nlhs nrhs + -- The "_SI" varant ensures that we make a new Wanted + -- with the same shadow-info as the existing one (#16735) ; let co = maybeSym swapped $ mkSymCo lhs_co `mkTransCo` hole_co diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -158,14 +158,22 @@ -- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on -- However, do not make any evidence bindings, because we don't -- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. -- See Note [Deferring coercion errors to runtime] -- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in TcSimplify] +-- (see Note [Fail fast on kind errors] in TcSimplify) -- and for simplifyDefault. reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds - ; report_unsolved TypeError HoleError HoleError HoleError + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; let type_holes | not partial_sigs = HoleError + | warn_partial_sigs = HoleWarn + | otherwise = HoleDefer + + ; report_unsolved TypeError HoleError type_holes HoleError ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to @@ -2007,11 +2015,11 @@ level = m_level `orElse` TypeLevel occurs_check_error - | Just act_tv <- tcGetTyVar_maybe act - , act_tv `elemVarSet` tyCoVarsOfType exp + | Just tv <- tcGetTyVar_maybe ty1 + , tv `elemVarSet` tyCoVarsOfType ty2 = True - | Just exp_tv <- tcGetTyVar_maybe exp - , exp_tv `elemVarSet` tyCoVarsOfType act + | Just tv <- tcGetTyVar_maybe ty2 + , tv `elemVarSet` tyCoVarsOfType ty1 = True | otherwise = False @@ -2035,13 +2043,17 @@ -> empty thing_msg = case maybe_thing of - Just thing -> \_ -> quotes thing <+> text "is" - Nothing -> \vowel -> text "got a" <> - if vowel then char 'n' else empty + Just thing -> \_ levity -> + quotes thing <+> text "is" <+> levity + Nothing -> \vowel levity -> + text "got a" <> + (if vowel then char 'n' else empty) <+> + levity <+> + text "type" msg2 = sep [ text "Expecting a lifted type, but" - , thing_msg True, text "unlifted" ] + , thing_msg True (text "unlifted") ] msg3 = sep [ text "Expecting an unlifted type, but" - , thing_msg False, text "lifted" ] + , thing_msg False (text "lifted") ] msg4 = maybe_num_args_msg $$ sep [ text "Expected a type, but" , maybe (text "found something with kind") diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -378,42 +378,35 @@ -- So: arg1_ty = arg2_ty -> op_res_ty -- where arg2_sigma maybe polymorphic; that's the point - ; arg2' <- tcArg op arg2 arg2_sigma 2 + ; arg2' <- tcArg op arg2 arg2_sigma 2 -- Make sure that the argument type has kind '*' -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b -- Eg we do not want to allow (D# $ 4.0#) #5570 -- (which gives a seg fault) - -- - -- The *result* type can have any kind (#8739), - -- so we don't need to check anything for that ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) (tcTypeKind arg2_sigma) liftedTypeKind - -- ignore the evidence. arg2_sigma must have type * or #, - -- because we know arg2_sigma -> or_res_ty is well-kinded + -- Ignore the evidence. arg2_sigma must have type * or #, + -- because we know (arg2_sigma -> op_res_ty) is well-kinded -- (because otherwise matchActualFunTys would fail) - -- There's no possibility here of, say, a kind family reducing to *. + -- So this 'unifyKind' will either succeed with Refl, or will + -- produce an insoluble constraint * ~ #, which we'll report later. - ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty - -- op_res -> res + -- NB: unlike the argument type, the *result* type, op_res_ty can + -- have any kind (#8739), so we don't need to check anything for that ; op_id <- tcLookupId op_name - ; res_ty <- readExpType res_ty - ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty + ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty , arg2_sigma - , res_ty]) + , op_res_ty]) (HsVar noExt (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) - -- wrap_res :: op_res_ty "->" res_ty - -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty + -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty - -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty) - wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc - <.> wrap_arg1 - doc = text "When looking at the argument to ($)" + expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' - ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') } + ; tcWrapResult expr expr' op_res_ty res_ty } | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op , Just sig_ty <- obviousSig (unLoc arg1) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-} +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} module TcFlatten( FlattenMode(..), @@ -485,14 +485,12 @@ -- See Note [The flattening work list]. newtype FlatM a = FlatM { runFlatM :: FlattenEnv -> TcS a } + deriving (Functor) instance Monad FlatM where m >>= k = FlatM $ \env -> do { a <- runFlatM m env ; runFlatM (k a) env } - -instance Functor FlatM where - fmap = liftM instance Applicative FlatM where pure x = FlatM $ const (pure x) diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -57,7 +57,7 @@ import PrelNames import DynFlags import Outputable -import Platform +import GHC.Platform import SrcLoc import Bag import Hooks diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -1,7 +1,19 @@ -module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..) - , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes - , withoutUnification ) where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits + , tcCheckHoleFit, tcSubsumes + , withoutUnification + , fromPureHFPlugin + -- Re-exports for convenience + , hfIsLcl + , pprHoleFit, debugHoleFitDispConfig + -- Re-exported from TcHoleFitTypes + , TypedHole (..), HoleFit (..), HoleFitCandidate (..) + , CandPlugin, FitPlugin + , HoleFitPlugin (..), HoleFitPluginR (..) + ) where + import GhcPrelude import TcRnTypes @@ -28,10 +40,9 @@ import Control.Arrow ( (&&&) ) -import Control.Monad ( filterM, replicateM ) +import Control.Monad ( filterM, replicateM, foldM ) import Data.List ( partition, sort, sortOn, nubBy ) import Data.Graph ( graphFromEdges, topSort ) -import Data.Function ( on ) import TcSimplify ( simpl_top, runTcSDeriveds ) @@ -39,13 +50,15 @@ import ExtractDocs ( extractDocs ) import qualified Data.Map as Map -import HsDoc ( HsDocString, unpackHDS, DeclDocMap(..) ) +import HsDoc ( unpackHDS, DeclDocMap(..) ) import HscTypes ( ModIface(..) ) import LoadIface ( loadInterfaceForNameMaybe ) import PrelInfo (knownKeyNames) +import TcHoleFitTypes + {- Note [Valid hole fits include ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -420,72 +433,6 @@ then BySize else NoSorting } - --- | HoleFitCandidates are passed to the filter and checked whether they can be --- made to fit. -data HoleFitCandidate = IdHFCand Id -- An id, like locals. - | NameHFCand Name -- A name, like built-in syntax. - | GreHFCand GlobalRdrElt -- A global, like imported ids. - deriving (Eq) -instance Outputable HoleFitCandidate where - ppr = pprHoleFitCand - -pprHoleFitCand :: HoleFitCandidate -> SDoc -pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id -pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name -pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre - -instance HasOccName HoleFitCandidate where - occName hfc = case hfc of - IdHFCand id -> occName id - NameHFCand name -> occName name - GreHFCand gre -> occName (gre_name gre) - --- | HoleFit is the type we use for valid hole fits. It contains the --- element that was checked, the Id of that element as found by `tcLookup`, --- and the refinement level of the fit, which is the number of extra argument --- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). -data HoleFit = - HoleFit { hfId :: Id -- The elements id in the TcM - , hfCand :: HoleFitCandidate -- The candidate that was checked. - , hfType :: TcType -- The type of the id, possibly zonked. - , hfRefLvl :: Int -- The number of holes in this fit. - , hfWrap :: [TcType] -- The wrapper for the match. - , hfMatches :: [TcType] -- What the refinement variables got matched - -- with, if anything - , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if - -- available. - - -hfName :: HoleFit -> Name -hfName hf = case hfCand hf of - IdHFCand id -> idName id - NameHFCand name -> name - GreHFCand gre -> gre_name gre - -hfIsLcl :: HoleFit -> Bool -hfIsLcl hf = case hfCand hf of - IdHFCand _ -> True - NameHFCand _ -> False - GreHFCand gre -> gre_lcl gre - --- We define an Eq and Ord instance to be able to build a graph. -instance Eq HoleFit where - (==) = (==) `on` hfId - --- We compare HoleFits by their name instead of their Id, since we don't --- want our tests to be affected by the non-determinism of `nonDetCmpVar`, --- which is used to compare Ids. When comparing, we want HoleFits with a lower --- refinement level to come first. -instance Ord HoleFit where - compare a b = cmp a b - where cmp = if hfRefLvl a == hfRefLvl b - then compare `on` hfName - else compare `on` hfRefLvl - -instance Outputable HoleFit where - ppr = pprHoleFit debugHoleFitDispConfig - -- If enabled, we go through the fits and add any associated documentation, -- by looking it up in the module or the environment (for local fits) addDocs :: [HoleFit] -> TcM [HoleFit] @@ -499,70 +446,70 @@ msg = text "TcHoleErrors addDocs" lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) = Map.lookup name dmap - upd lclDocs fit = - let name = hfName fit in - do { doc <- if hfIsLcl fit - then pure (Map.lookup name lclDocs) - else do { mbIface <- loadInterfaceForNameMaybe msg name - ; return $ mbIface >>= lookupInIface name } - ; return $ fit {hfDoc = doc} } + upd lclDocs fit@(HoleFit {hfCand = cand}) = + do { let name = getName cand + ; doc <- if hfIsLcl fit + then pure (Map.lookup name lclDocs) + else do { mbIface <- loadInterfaceForNameMaybe msg name + ; return $ mbIface >>= lookupInIface name } + ; return $ fit {hfDoc = doc} } + upd _ fit = return fit -- For pretty printing hole fits, we display the name and type of the fit, -- with added '_' to represent any extra arguments in case of a non-zero -- refinement level. pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc -pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance - where name = hfName hf - ty = hfType hf - matches = hfMatches hf - wrap = hfWrap hf - tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars wrap - where pprArg b arg = case binderArgFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty - Required -> pprPanic "pprHoleFit: bad Required" +pprHoleFit _ (RawHoleFit sd) = sd +pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = + hang display 2 provenance + where name = getName hfCand + tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap + where pprArg b arg = case binderArgFlag b of + Specified -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + Inferred -> empty + Required -> pprPanic "pprHoleFit: bad Required" (ppr b <+> ppr arg) - tyAppVars = sep $ punctuate comma $ - zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> - text "~" <+> pprParendType t) - vars wrap + tyAppVars = sep $ punctuate comma $ + zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> + text "~" <+> pprParendType t) + vars hfWrap - vars = unwrapTypeVars ty - where - -- Attempts to get all the quantified type variables in a type, - -- e.g. - -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) - -- into [m, a] - unwrapTypeVars :: Type -> [TyCoVarBinder] - unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, unfunned) -> unwrapTypeVars unfunned - _ -> [] - where (vars, unforalled) = splitForAllVarBndrs t - holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches - holeDisp = if sMs then holeVs - else sep $ replicate (length matches) $ text "_" - occDisp = pprPrefixOcc name - tyDisp = ppWhen sTy $ dcolon <+> ppr ty - has = not . null - wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars)) - $ text "with" <+> if sWrp || not sTy - then occDisp <+> tyApp - else tyAppVars - docs = case hfDoc hf of - Just d -> text "{-^" <> - (vcat . map text . lines . unpackHDS) d - <> text "-}" - _ -> empty - funcInfo = ppWhen (has matches && sTy) $ - text "where" <+> occDisp <+> tyDisp - subDisp = occDisp <+> if has matches then holeDisp else tyDisp - display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) - provenance = ppWhen sProv $ parens $ - case hfCand hf of - GreHFCand gre -> pprNameProvenance gre - _ -> text "bound at" <+> ppr (getSrcLoc name) + vars = unwrapTypeVars hfType + where + -- Attempts to get all the quantified type variables in a type, + -- e.g. + -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) + -- into [m, a] + unwrapTypeVars :: Type -> [TyCoVarBinder] + unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of + Just (_, unfunned) -> unwrapTypeVars unfunned + _ -> [] + where (vars, unforalled) = splitForAllVarBndrs t + holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches + holeDisp = if sMs then holeVs + else sep $ replicate (length hfMatches) $ text "_" + occDisp = pprPrefixOcc name + tyDisp = ppWhen sTy $ dcolon <+> ppr hfType + has = not . null + wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) + $ text "with" <+> if sWrp || not sTy + then occDisp <+> tyApp + else tyAppVars + docs = case hfDoc of + Just d -> text "{-^" <> + (vcat . map text . lines . unpackHDS) d + <> text "-}" + _ -> empty + funcInfo = ppWhen (has hfMatches && sTy) $ + text "where" <+> occDisp <+> tyDisp + subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp + display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) + provenance = ppWhen sProv $ parens $ + case hfCand of + GreHFCand gre -> pprNameProvenance gre + _ -> text "bound at" <+> ppr (getSrcLoc name) getLocalBindings :: TidyEnv -> Ct -> TcM [Id] getLocalBindings tidy_orig ct @@ -598,11 +545,15 @@ ; maxVSubs <- maxValidHoleFits <$> getDynFlags ; hfdc <- getHoleFitDispConfig ; sortingAlg <- getSortingAlg + ; dflags <- getDynFlags + ; hfPlugs <- tcg_hf_plugins <$> getGblEnv ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs - ; refLevel <- refLevelHoleFits <$> getDynFlags - ; traceTc "findingValidHoleFitsFor { " $ ppr ct + refLevel = refLevelHoleFits dflags + hole = TyH (listToBag relevantCts) implics (Just ct) + (candidatePlugins, fitPlugins) = + unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs + ; traceTc "findingValidHoleFitsFor { " $ ppr hole ; traceTc "hole_lvl is:" $ ppr hole_lvl - ; traceTc "implics are: " $ ppr implics ; traceTc "simples are: " $ ppr simples ; traceTc "locals are: " $ ppr lclBinds ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) @@ -615,11 +566,14 @@ globals = map GreHFCand gbl syntax = map NameHFCand builtIns to_check = locals ++ syntax ++ globals + ; cands <- foldM (flip ($)) to_check candidatePlugins + ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) ; (searchDiscards, subs) <- - tcFilterHoleFits findVLimit implics relevantCts (hole_ty, []) to_check + tcFilterHoleFits findVLimit hole (hole_ty, []) cands ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs - ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs + ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins + ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs vDiscards = pVDisc || searchDiscards ; subs_with_docs <- addDocs limited_subs ; let vMsg = ppUnless (null subs_with_docs) $ @@ -638,8 +592,8 @@ ; traceTc "ref_tys are" $ ppr ref_tys ; let findRLimit = if sortingAlg > NoSorting then Nothing else maxRSubs - ; refDs <- mapM (flip (tcFilterHoleFits findRLimit implics - relevantCts) to_check) ref_tys + ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) + cands) ref_tys ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs -- For refinement substitutions we want matches @@ -649,8 +603,10 @@ ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs - (pRDisc, exact_last_rfits) = - possiblyDiscard maxRSubs $ not_exact ++ exact + ; plugin_handled_rsubs <- foldM (flip ($)) + (not_exact ++ exact) fitPlugins + ; let (pRDisc, exact_last_rfits) = + possiblyDiscard maxRSubs $ plugin_handled_rsubs rDiscards = pRDisc || any fst refDs ; rsubs_with_docs <- addDocs exact_last_rfits ; return (tidy_env, @@ -732,6 +688,9 @@ where zonkSubs' zs env [] = return (env, reverse zs) zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf ; zonkSubs' (z:zs) env' hfs } + + zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit) + zonkSub env hf@RawHoleFit{} = return (env, hf) zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} = do { (env, ty') <- zonkTidyTcType env ty ; (env, m') <- zonkTidyTcTypes env m @@ -786,10 +745,7 @@ -- running the type checker. Stops after finding limit matches. tcFilterHoleFits :: Maybe Int -- ^ How many we should output, if limited - -> [Implication] - -- ^ Enclosing implications for givens - -> [Ct] - -- ^ Any relevant unsolved simple constraints + -> TypedHole -- ^ The hole to filter against -> (TcType, [TcTyVar]) -- ^ The type to check for fits and a list of refinement -- variables (free type variables in the type) for emulating @@ -799,8 +755,8 @@ -> TcM (Bool, [HoleFit]) -- ^ We return whether or not we stopped due to hitting the limit -- and the fits we found. -tcFilterHoleFits (Just 0) _ _ _ _ = return (False, []) -- Stop right away on 0 -tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates = +tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 +tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates = do { traceTc "checkingFitsFor {" $ ppr hole_ty ; (discards, subs) <- go [] emptyVarSet limit ht candidates ; traceTc "checkingFitsFor }" empty @@ -901,7 +857,7 @@ -- refinement hole fits, so we can't wrap the side-effects deeper than this. withoutUnification fvs $ do { traceTc "checkingFitOf {" $ ppr ty - ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty + ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty ; traceTc "Did it fit?" $ ppr fits ; traceTc "wrap is: " $ ppr wrp ; traceTc "checkingFitOf }" empty @@ -934,6 +890,7 @@ else return Nothing } else return Nothing } where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty + hole = TyH tyHRelevantCts tyHImplics Nothing subsDiscardMsg :: SDoc @@ -970,8 +927,8 @@ -- discarding any errors. Subsumption here means that the ty_b can fit into the -- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool -tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b - +tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b + where dummyHole = TyH emptyBag [] Nothing -- | A tcSubsumes which takes into account relevant constraints, to fix trac -- #14273. This makes sure that when checking whether a type fits the hole, @@ -979,24 +936,22 @@ -- constraints on the type of the hole. -- Note: The simplifier may perform unification, so make sure to restore any -- free type variables to avoid side-effects. -tcCheckHoleFit :: Cts -- ^ Any relevant Cts to the hole. - -> [Implication] - -- ^ The nested implications of the hole with the innermost - -- implication first. - -> TcSigmaType -- ^ The type of the hole. - -> TcSigmaType -- ^ The type to check whether fits. +tcCheckHoleFit :: TypedHole -- ^ The hole to check against + -> TcSigmaType + -- ^ The type to check against (possibly modified, e.g. refined) + -> TcSigmaType -- ^ The type to check whether fits. -> TcM (Bool, HsWrapper) -- ^ Whether it was a match, and the wrapper from hole_ty to ty. -tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty +tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty = return (True, idHsWrapper) -tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $ +tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ do { -- We wrap the subtype constraint in the implications to pass along the -- givens, and so we must ensure that any nested implications and skolems -- end up with the correct level. The implications are ordered so that -- the innermost (the one with the highest level) is first, so it -- suffices to get the level of the first one (or the current level, if -- there are no implications involved). - innermost_lvl <- case implics of + innermost_lvl <- case tyHImplics of [] -> getTcLevel -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) @@ -1004,15 +959,15 @@ tcSubType_NC ExprSigCtxt ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted - ; if isEmptyWC wanted && isEmptyBag relevantCts + ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts then traceTc "}" empty >> return (True, wrp) else do { fresh_binds <- newTcEvBinds -- The relevant constraints may contain HoleDests, so we must -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWanted relevantCts + ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts -- We wrap the WC in the nested implications, see -- Note [Nested Implications] - ; let outermost_first = reverse implics + ; let outermost_first = reverse tyHImplics setWC = setWCAndBinds fresh_binds -- We add the cloned relevants to the wanteds generated by -- the call to tcSubType_NC, see Note [Relevant Constraints] @@ -1035,3 +990,10 @@ setWCAndBinds binds imp wc = WC { wc_simple = emptyBag , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } } + +-- | Maps a plugin that needs no state to one with an empty one. +fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR +fromPureHFPlugin plug = + HoleFitPluginR { hfPluginInit = newTcRef () + , hfPluginRun = const plug + , hfPluginStop = const $ return () } diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -11,7 +11,7 @@ module TcHsType ( -- Type signatures - kcHsSigType, tcClassSigType, + kcClassSigType, tcClassSigType, tcHsSigType, tcHsSigWcType, tcHsPartialSigType, funsSigCtxt, addSigCtxt, pprSigCtxt, @@ -36,7 +36,7 @@ -- Kind-checking types -- No kind generalisation, no checkValidType kcLHsQTyVars, - tcWildCardBinders, + tcNamedWildCardBinders, tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType, @@ -49,7 +49,7 @@ kindGeneralize, checkExpectedKind_pp, -- Sort-checking kinds - tcLHsKindSig, badKindSig, + tcLHsKindSig, checkDataKindSig, DataSort(..), -- Zonking and promoting zonkPromoteType, @@ -105,7 +105,7 @@ import Outputable import FastString import PrelNames hiding ( wildCardName ) -import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) ) +import DynFlags import qualified GHC.LanguageExtensions as LangExt import Maybes @@ -187,24 +187,40 @@ -- already checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM () -kcHsSigType names (HsIB { hsib_body = hs_ty - , hsib_ext = sig_vars }) - = discardResult $ - addSigCtxt (funsSigCtxt names) hs_ty $ - bindImplicitTKBndrs_Skol sig_vars $ - tc_lhs_type typeLevelMode hs_ty liftedTypeKind - -kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType" +kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () +kcClassSigType skol_info names sig_ty + = discardResult $ + tcClassSigType skol_info names sig_ty + -- tcClassSigType does a fair amount of extra work that we don't need, + -- such as ordering quantified variables. But we absolutely do need + -- to push the level when checking method types and solve local equalities, + -- and so it seems easier just to call tcClassSigType than selectively + -- extract the lines of code from tc_hs_sig_type that we really need. + -- If we don't push the level, we get #16517, where GHC accepts + -- class C a where + -- meth :: forall k. Proxy (a :: k) -> () + -- Note that k is local to meth -- this is hogwash. tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType skol_info names sig_ty = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) -- Do not zonk-to-Type, nor perform a validity check -- We are in a knot with the class and associated types -- Zonking and validity checking is done by tcClassDecl + -- No need to fail here if the type has an error: + -- If we're in the kind-checking phase, the solveEqualities + -- in kcTyClGroup catches the error + -- If we're in the type-checking phase, the solveEqualities + -- in tcClassDecl1 gets it + -- Failing fast here degrades the error message in, e.g., tcfail135: + -- class Foo f where + -- baa :: f a -> f + -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. + -- It should be that f has kind `k2 -> *`, but we never get a chance + -- to run the solver where the kind of f is touchable. This is + -- painfully delicate. tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Does validity checking @@ -214,10 +230,13 @@ do { traceTc "tcHsSigType {" (ppr sig_ty) -- Generalise here: see Note [Kind generalisation] - ; ty <- tc_hs_sig_type skol_info sig_ty - (expectedKindInCtxt ctxt) + ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty + (expectedKindInCtxt ctxt) ; ty <- zonkTcType ty + ; when insol failM + -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify + ; checkValidType ctxt ty ; traceTc "end tcHsSigType }" (ppr ty) ; return ty } @@ -225,12 +244,14 @@ skol_info = SigTypeSkol ctxt tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM Type + -> ContextKind -> TcM (Bool, TcType) -- Kind-checks/desugars an 'LHsSigType', -- solve equalities, -- and then kind-generalizes. -- This will never emit constraints, as it uses solveEqualities interally. -- No validity checking or zonking +-- Returns also a Bool indicating whether the type induced an insoluble constraint; +-- True <=> constraint is insoluble tc_hs_sig_type skol_info hs_sig_type ctxt_kind | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type = do { (tc_lvl, (wanted, (spec_tkvs, ty))) @@ -248,11 +269,7 @@ ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) tc_lvl wanted - -- See Note [Fail fast if there are insoluble kind equalities] - -- in TcSimplify - ; when (insolubleWC wanted) failM - - ; return (mkInvForAllTys kvs ty1) } + ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type" @@ -370,7 +387,7 @@ unsetWOptM Opt_WarnPartialTypeSignatures $ setXOptM LangExt.PartialTypeSignatures $ -- See Note [Wildcards in visible type application] - tcWildCardBinders sig_wcs $ \ _ -> + tcNamedWildCardBinders sig_wcs $ \ _ -> tcCheckLHsType hs_ty kind -- We must promote here. Ex: -- f :: forall a. a @@ -385,18 +402,19 @@ {- Note [Wildcards in visible type application] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed -wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType -will call emitWildCardHoleConstraints on them. However, this would trigger -error/warning when an unnamed wildcard is passed in as a visible type argument, -which we do not want because users should be able to write @_ to skip a instantiating -a type variable variable without fuss. The solution is to switch the -PartialTypeSignatures flags here to let the typechecker know that it's checking -a '@_' and do not emit hole constraints on it. -See related Note [Wildcards in visible kind application] -and Note [The wildcard story for types] in HsTypes.hs +A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so +any unnamed wildcards stay unchanged in hswc_body. When called in +tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint +on these anonymous wildcards. However, this would trigger +error/warning when an anonymous wildcard is passed in as a visible type +argument, which we do not want because users should be able to write +@_ to skip a instantiating a type variable variable without fuss. The +solution is to switch the PartialTypeSignatures flags here to let the +typechecker know that it's checking a '@_' and do not emit hole +constraints on it. See related Note [Wildcards in visible kind +application] and Note [The wildcard story for types] in HsTypes.hs +Ugh! -} {- @@ -812,7 +830,7 @@ tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type _ wc@(HsWildCardTy _) ek = tcWildCardOcc wc ek +tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek ------------------------------------------ tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind @@ -832,18 +850,18 @@ liftedTypeKind exp_kind } --------------------------- -tcWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType -tcWildCardOcc wc exp_kind - = do { wc_tv <- newWildTyVar - -- The wildcard's kind should be an un-filled-in meta tyvar - ; loc <- getSrcSpanM - ; uniq <- newUnique - ; let name = mkInternalName uniq (mkTyVarOcc "_") loc +tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType +tcAnonWildCardOcc wc exp_kind + = do { wc_tv <- newWildTyVar -- The wildcard's kind will be an un-filled-in meta tyvar + ; part_tysig <- xoptM LangExt.PartialTypeSignatures ; warning <- woptM Opt_WarnPartialTypeSignatures - -- See Note [Wildcards in visible kind application] - ; unless (part_tysig && not warning) - (emitWildCardHoleConstraints [(name,wc_tv)]) + + ; unless (part_tysig && not warning) $ + emitAnonWildCardHoleConstraint wc_tv + -- Why the 'unless' guard? + -- See Note [Wildcards in visible kind application] + ; checkExpectedKind wc (mkTyVarTy wc_tv) (tyVarKind wc_tv) exp_kind } @@ -860,11 +878,11 @@ So we should allow '@_' without emitting any hole constraints, and regardless of whether PartialTypeSignatures is enabled or not. But how would the typechecker know which '_' is being used in VKA and which is not when it -calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? +calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, -but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc. +but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. And whenever we see a '@', we automatically turn on PartialTypeSignatures and -turn off hole constraint warnings, and never call emitWildCardHoleConstraints +turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint under these conditions. See related Note [Wildcards in visible type application] here and Note [The wildcard story for types] in HsTypes.hs @@ -1705,23 +1723,26 @@ gathers free variables. So this way effectively sidesteps step 3. -} -tcWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a -tcWildCardBinders wc_names thing_inside +tcNamedWildCardBinders :: [Name] + -> ([(Name, TcTyVar)] -> TcM a) + -> TcM a +-- Bring into scope the /named/ wildcard binders. Remember that +-- plain wildcards _ are anonymous and dealt with by HsWildCardTy +-- Soe Note [The wildcard story for types] in HsTypes +tcNamedWildCardBinders wc_names thing_inside = do { wcs <- mapM (const newWildTyVar) wc_names ; let wc_prs = wc_names `zip` wcs ; tcExtendNameTyVarEnv wc_prs $ thing_inside wc_prs } newWildTyVar :: TcM TcTyVar --- ^ New unification variable for a wildcard +-- ^ New unification variable '_' for a wildcard newWildTyVar = do { kind <- newMetaKindVar ; uniq <- newUnique ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "_") - tyvar = (mkTcTyVar name kind details) + ; let name = mkSysTvName uniq (fsLit "_") + tyvar = mkTcTyVar name kind details ; traceTc "newWildTyVar" (ppr tyvar) ; return tyvar } @@ -2105,8 +2126,6 @@ bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) --- | Used during the "kind-checking" pass in TcTyClsDecls only, --- and even then only for data-con declarations. bindExplicitTKBndrsX :: (HsTyVarBndr GhcRn -> TcM TcTyVar) -> [LHsTyVarBndr GhcRn] @@ -2225,7 +2244,8 @@ -- Quantify the free kind variables of a kind or type -- In the latter case the type is closed, so it has no free -- type variables. So in both cases, all the free vars are kind vars --- Input needn't be zonked. +-- Input needn't be zonked. All variables to be quantified must +-- have a TcLevel higher than the ambient TcLevel. -- NB: You must call solveEqualities or solveLocalEqualities before -- kind generalization -- @@ -2243,7 +2263,8 @@ -- | This variant of 'kindGeneralize' refuses to generalize over any -- variables free in the given WantedConstraints. Instead, it promotes --- these variables into an outer TcLevel. See also +-- these variables into an outer TcLevel. All variables to be quantified must +-- have a TcLevel higher than the ambient TcLevel. See also -- Note [Promoting unification variables] in TcSimplify kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar] kindGeneralizeLocal wanted kind_or_type @@ -2384,13 +2405,102 @@ (subst', tv') = substTyVarBndr subst tv tcb = Bndr tv' (NamedTCB vis) -badKindSig :: Bool -> Kind -> SDoc -badKindSig check_for_type kind - = hang (sep [ text "Kind signature on data type declaration has non-*" - , (if check_for_type then empty else text "and non-variable") <+> - text "return kind" ]) - 2 (ppr kind) +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "TcTyClsDecls". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +checkDataKindSig :: DataSort -> Kind -> TcM () +checkDataKindSig data_sort kind = do + dflags <- getDynFlags + checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags) + where + pp_dec :: SDoc + pp_dec = text $ + case data_sort of + DataDeclSort DataType -> "data type" + DataDeclSort NewType -> "newtype" + DataInstanceSort DataType -> "data instance" + DataInstanceSort NewType -> "newtype instance" + DataFamilySort -> "data family" + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + tYPE_ok :: DynFlags -> Bool + tYPE_ok dflags = + (is_newtype && xopt LangExt.UnliftedNewtypes dflags) + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls. + || is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + + is_TYPE :: Bool + is_TYPE = tcIsRuntimeTypeKind kind + + is_TYPE_or_Type :: DynFlags -> Bool + is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE + | otherwise = tcIsLiftedTypeKind kind + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind) + | otherwise = False + + err_msg :: DynFlags -> SDoc + err_msg dflags = + sep [ (sep [ text "Kind signature on" <+> pp_dec <+> + text "declaration has non-" <> + (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) ]) + , if not (tYPE_ok dflags) && is_TYPE && is_newtype && + not (xopt LangExt.UnliftedNewtypes dflags) + then text "Perhaps you intended to use UnliftedNewtypes" + else empty ] + tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] -- Result is in 1-1 correpondence with orig_args tcbVisibilities tc orig_args @@ -2473,11 +2583,11 @@ -> LHsSigWcType GhcRn -- The type signature -> TcM ( [(Name, TcTyVar)] -- Wildcards , Maybe TcType -- Extra-constraints wildcard - , [Name] -- Original tyvar names, in correspondence with ... - , [TcTyVar] -- ... Implicitly and explicitly bound type variables + , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with + -- the implicitly and explicitly bound type variables , TcThetaType -- Theta part , TcType ) -- Tau part --- See Note [Recipe for checking a signature] +-- See Note [Checking partial type signatures] tcHsPartialSigType ctxt sig_ty | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty , HsIB { hsib_ext = implicit_hs_tvs @@ -2485,8 +2595,11 @@ , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty = addSigCtxt ctxt hs_ty $ do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) - <- solveLocalEqualities "tcHsPatSigTypes" $ - tcWildCardBinders sig_wcs $ \ wcs -> + <- solveLocalEqualities "tcHsPartialSigType" $ + -- This solveLocalEqualiltes fails fast if there are + -- insoluble equalities. See TcSimplify + -- Note [Fail fast if there are insoluble kind equalities] + tcNamedWildCardBinders sig_wcs $ \ wcs -> bindImplicitTKBndrs_Tv implicit_hs_tvs $ bindExplicitTKBndrs_Tv explicit_hs_tvs $ do { -- Instantiate the type-class context; but if there @@ -2497,38 +2610,23 @@ ; return (wcs, wcx, theta, tau) } - -- We must return these separately, because all the zonking below - -- might change the name of a TyVarTv. This, in turn, causes trouble - -- in partial type signatures that bind scoped type variables, as - -- we bring the wrong name into scope in the function body. - -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let tv_names = implicit_hs_tvs ++ hsLTyVarNames explicit_hs_tvs - -- Spit out the wildcards (including the extra-constraints one) -- as "hole" constraints, so that they'll be reported if necessary -- See Note [Extra-constraint holes in partial type signatures] - ; emitWildCardHoleConstraints wcs - - -- The TyVarTvs created above will sometimes have too high a TcLevel - -- (note that they are generated *after* bumping the level in - -- the tc{Im,Ex}plicitTKBndrsSig functions. Bumping the level - -- is still important here, because the kinds of these variables - -- do indeed need to have the higher level, so they can unify - -- with other local type variables. But, now that we've type-checked - -- everything (and solved equalities in the tcImplicit call) - -- we need to promote the TyVarTvs so we don't violate the TcLevel - -- invariant - ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; explicit_tvs <- mapM zonkAndSkolemise explicit_tvs - ; theta <- mapM zonkTcType theta - ; tau <- zonkTcType tau + ; emitNamedWildCardHoleConstraints wcs - ; let all_tvs = implicit_tvs ++ explicit_tvs + -- We return a proper (Name,TyVar) environment, to be sure that + -- we bring the right name into scope in the function body. + -- Test case: partial-sigs/should_compile/LocalDefinitionBug + ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) + ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) - ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau) + -- NB: checkValidType on the final inferred type will be + -- done later by checkInferredPolyId. We can't do it + -- here because we don't have a complete tuype to check - ; traceTc "tcHsPartialSigType" (ppr all_tvs) - ; return (wcs, wcx, tv_names, all_tvs, theta, tau) } + ; traceTc "tcHsPartialSigType" (ppr tv_prs) + ; return (wcs, wcx, tv_prs, theta, tau) } tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType" tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType" @@ -2538,14 +2636,43 @@ | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { wc_tv_ty <- setSrcSpan wc_loc $ - tcWildCardOcc wc constraintKind + tcAnonWildCardOcc wc constraintKind ; theta <- mapM tcLHsPredType hs_theta1 ; return (theta, Just wc_tv_ty) } | otherwise = do { theta <- mapM tcLHsPredType hs_theta ; return (theta, Nothing) } -{- Note [Extra-constraint holes in partial type signatures] +{- Note [Checking partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Recipe for checking a signature] + +When we have a parital signature like + f,g :: forall a. a -> _ +we do the following + +* In TcSigs.tcUserSigType we return a PartialSig, which (unlike + the companion CompleteSig) contains the original, as-yet-unchecked + source-code LHsSigWcType + +* Then, for f and g /separately/, we call tcInstSig, which in turn + call tchsPartialSig (defined near this Note). It kind-checks the + LHsSigWcType, creating fresh unification variables for each "_" + wildcard. It's important that the wildcards for f and g are distinct + becase they migh get instantiated completely differently. E.g. + f,g :: forall a. a -> _ + f x = a + g x = True + It's really as if we'd written two distinct signatures. + +* Note that we don't make quantified type (forall a. blah) and then + instantiate it -- it makes no sense to instantiate a type with + wildcards in it. Rather, tcHsPartialSigType just returns the + 'a' and the 'blah' separately. + + Nor, for the same reason, do we push a level in tcHsPartialSigType. + +Note [Extra-constraint holes in partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f :: (_) => a -> a @@ -2614,12 +2741,12 @@ -- Always solve local equalities if possible, -- else casts get in the way of deep skolemisation -- (#16033) - tcWildCardBinders sig_wcs $ \ wcs -> + tcNamedWildCardBinders sig_wcs $ \ wcs -> tcExtendNameTyVarEnv sig_tkv_prs $ do { sig_ty <- tcHsOpenType hs_ty ; return (wcs, sig_ty) } - ; emitWildCardHoleConstraints wcs + ; emitNamedWildCardHoleConstraints wcs -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty -- contains a forall). Promote these. diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -472,8 +472,7 @@ , cid_datafam_insts = adts })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 hs_ty) $ - do { traceTc "tcLocalInstDecl" (ppr hs_ty) - ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty + do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty -- NB: tcHsClsInstType does checkValidInstance @@ -660,10 +659,10 @@ ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in FamInstEnv - ; (qtvs, pats, res_kind, stupid_theta) <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons + new_or_data -- Eta-reduce the axiom if possible -- Quite tricky: see Note [Eta-reduction for data families] @@ -679,13 +678,16 @@ -- first, so there is no reason to suppose that the eta_tvs -- (obtained from the pats) are at the end (#11148) - -- Eta-expand the representation tycon until it has reult kind * + -- Eta-expand the representation tycon until it has result + -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we + -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. + -- -- See also Note [Arity of data families] in FamInstEnv -- NB: we can do this after eta-reducing the axiom, because if -- we did it before the "extra" tvs from etaExpandAlgTyCon -- would always be eta-reduced ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind - ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind) + ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs all_pats = pats `chkAppend` extra_pats orig_res_ty = mkTyConApp fam_tc all_pats @@ -703,9 +705,10 @@ ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> do { data_cons <- tcExtendTyVarEnv qtvs $ - -- For H98 decls, the tyvars scope - -- over the data constructors - tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons + -- For H98 decls, the tyvars scope + -- over the data constructors + tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind + orig_res_ty hs_cons ; rep_tc_name <- newFamInstTyConName lfam_name pats ; axiom_name <- newFamInstAxiomName lfam_name [pats] @@ -722,7 +725,7 @@ -- NB: Use the full ty_binders from the pats. See bullet toward -- the end of Note [Data type families] in TyCon rep_tc = mkAlgTyCon rep_tc_name - ty_binders liftedTypeKind + ty_binders final_res_kind (map (const Nominal) ty_binders) (fmap unLoc cType) stupid_theta tc_rhs parent @@ -782,12 +785,14 @@ tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] -> LexicalFixity -> LHsContext GhcRn -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] + -> NewOrData -> TcM ([TyVar], [Type], Kind, ThetaType) -- The "header" is the part other than the data constructors themselves -- e.g. data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where" -tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons - = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind))) +tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt + hs_pats m_ksig hs_cons new_or_data + = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty))) <- pushTcLevelM_ $ solveEqualities $ bindImplicitTKBndrs_Q_Skol imp_vars $ @@ -799,17 +804,16 @@ -- with its parent class ; addConsistencyConstraints mb_clsinfo lhs_ty - -- Add constraints from the data constructors - ; mapM_ (wrapLocM_ kcConDecl) hs_cons - -- Add constraints from the result signature ; res_kind <- tc_kind_sig m_ksig + -- Add constraints from the data constructors + ; mapM_ (wrapLocM_ (kcConDecl new_or_data res_kind)) hs_cons ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind - ; return (stupid_theta, lhs_ty, res_kind) } + ; return (stupid_theta, lhs_ty) } -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts] -- This code (and the stuff immediately above) is very similar - -- to that in tcFamTyInstEqnGuts. Maybe we should abstract the + -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the -- common code; but for the moment I concluded that it's -- clearer to duplicate it. Still, if you fix a bug here, -- check there too! @@ -819,22 +823,33 @@ -- Zonk the patterns etc into the Type world ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; res_kind <- zonkTcTypeToTypeX ze res_kind + -- See Note [Unifying data family kinds] about the discardCast + ; lhs_ty <- zonkTcTypeToTypeX ze (discardCast lhs_ty) ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta -- Check that type patterns match the class instance head - ; let pats = unravelFamInstPats lhs_ty - ; return (qtvs, pats, res_kind, stupid_theta) } + -- The call to splitTyConApp_maybe here is just an inlining of + -- the body of unravelFamInstPats. + ; pats <- case splitTyConApp_maybe lhs_ty of + Just (_, pats) -> pure pats + Nothing -> pprPanic "tcDataFamHeader" (ppr lhs_ty) + ; return (qtvs, pats, typeKind lhs_ty, stupid_theta) } + -- See Note [Unifying data family kinds] about why we need typeKind here where fam_name = tyConName fam_tc data_ctxt = DataKindCtxt fam_name pp_lhs = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt exp_bndrs = mb_bndrs `orElse` [] - -- See Note [Result kind signature for a data family instance] + -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2). tc_kind_sig Nothing - = return liftedTypeKind + = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; if unlifted_newtypes && new_or_data == NewType + then newOpenTypeKind + else pure liftedTypeKind + } + + -- See Note [Result kind signature for a data family instance] tc_kind_sig (Just hs_kind) = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind @@ -851,6 +866,36 @@ we actually have a place to put the regeneralised variables. Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise Examples in indexed-types/should_compile/T12369 + +Note [Unifying data family kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we kind-check a newtype instance with -XUnliftedNewtypes, we must +unify the kind of the data family with any declared kind in the instance +declaration. For example: + + data Color = Red | Blue + type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep + data family Foo (x :: Color) :: TYPE (Interpret x) + newtype instance Foo 'Red :: TYPE IntRep where + FooRedC :: Int# -> Foo 'Red + +We end up unifying `TYPE (Interpret 'Red)` (the kind of Foo, instantiated +with 'Red) and `TYPE IntRep` (the declared kind of the instance). This +unification succeeds, resulting in a coercion. The big question: what to +do with this coercion? Answer: nothing! A kind annotation on a newtype instance +is always redundant (except, perhaps, in that it helps guide unification). We +have a definitive kind for the data family from the data family declaration, +and so we learn nothing really new from the kind signature on an instance. +We still must perform this unification (done in the call to checkExpectedKind +toward the beginning of tcDataFamHeader), but the result is unhelpful. If there +is a cast, it will wrap the lhs_ty, and so we just drop it before splitting the +lhs_ty to reveal the underlying patterns. Because of the potential of dropping +a cast like this, we just use typeKind in the result instead of propagating res_kind +from above. + +This Note is wrinkle (3) in Note [Implementation of UnliftedNewtypes] in TcTyClsDecls. Note [Eta-reduction for data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -80,6 +80,7 @@ zonkCt, zonkSkolemInfo, tcGetGlobalTyCoVars, + skolemiseUnboundMetaTyVar, ------------------------------ -- Levity polymorphism @@ -834,14 +835,14 @@ -- Everything from here on only happens if DEBUG is on | not (isTcTyVar tyvar) - = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar ) + = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) return () | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar = writeMetaTyVarRef tyvar ref ty | otherwise - = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) + = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) return () -------------------- @@ -1094,18 +1095,18 @@ forall arg. ... (alpha[tau]:arg) ... We have a metavariable alpha whose kind mentions a skolem variable -boudn inside the very type we are generalising. +bound inside the very type we are generalising. This can arise while type-checking a user-written type signature (see the test case for the full code). We cannot generalise over alpha! That would produce a type like forall {a :: arg}. forall arg. ...blah... The fact that alpha's kind mentions arg renders it completely -ineligible for generaliation. +ineligible for generalisation. However, we are not going to learn any new constraints on alpha, -because its kind isn't even in scope in the outer context. So alpha -is entirely unconstrained. +because its kind isn't even in scope in the outer context (but see Wrinkle). +So alpha is entirely unconstrained. What then should we do with alpha? During generalization, every metavariable is either (A) promoted, (B) generalized, or (C) zapped @@ -1126,6 +1127,17 @@ generalisation, because at that moment we have a clear picture of what skolems are in scope. +Wrinkle: + +We must make absolutely sure that alpha indeed is not +from an outer context. (Otherwise, we might indeed learn more information +about it.) This can be done easily: we just check alpha's TcLevel. +That level must be strictly greater than the ambient TcLevel in order +to treat it as naughty. We say "strictly greater than" because the call to +candidateQTyVars is made outside the bumped TcLevel, as stated in the +comment to candidateQTyVarsOfType. The level check is done in go_tv +in collect_cant_qtvs. Skipping this check caused #16517. + -} data CandidatesQTvs @@ -1173,13 +1185,17 @@ -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind. +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -- See Note [CandidatesQTvs determinism and order] -- See Note [Dependent type variables] candidateQTyVarsOfType :: TcType -- not necessarily zonked -> TcM CandidatesQTvs candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty --- | Like 'splitDepVarsOfType', but over a list of types +-- | Like 'candidateQTyVarsOfType', but over a list of types +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys @@ -1203,7 +1219,7 @@ collect_cand_qtvs :: Bool -- True <=> consider every fv in Type to be dependent - -> VarSet -- Bound variables (both locally bound and globally bound) + -> VarSet -- Bound variables (locals only) -> CandidatesQTvs -- Accumulating parameter -> Type -- Not necessarily zonked -> TcM CandidatesQTvs @@ -1248,17 +1264,27 @@ ----------------- go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | tv `elemDVarSet` kvs = return dv -- We have met this tyvar aleady + | tv `elemDVarSet` kvs + = return dv -- We have met this tyvar aleady + | not is_dep - , tv `elemDVarSet` tvs = return dv -- We have met this tyvar aleady + , tv `elemDVarSet` tvs + = return dv -- We have met this tyvar aleady + | otherwise = do { tv_kind <- zonkTcType (tyVarKind tv) -- This zonk is annoying, but it is necessary, both to -- ensure that the collected candidates have zonked kinds -- (#15795) and to make the naughty check -- (which comes next) works correctly - ; if intersectsVarSet bound (tyCoVarsOfType tv_kind) + ; cur_lvl <- getTcLevel + ; if tcTyVarLevel tv `strictlyDeeperThan` cur_lvl && + -- this tyvar is from an outer context: see Wrinkle + -- in Note [Naughty quantification candidates] + + intersectsVarSet bound (tyCoVarsOfType tv_kind) + then -- See Note [Naughty quantification candidates] do { traceTc "Zapping naughty quantifier" (pprTyVar tv) ; writeMetaTyVar tv (anyTypeOfKind tv_kind) @@ -1407,9 +1433,9 @@ -- NB: All variables in the kind of a covar must not be -- quantified over, as we don't quantify over the covar. - dep_kvs = dVarSetElemsWellScoped $ + dep_kvs = scopedSort $ dVarSetElems $ dep_tkvs `dVarSetMinusVarSet` mono_tvs - -- dVarSetElemsWellScoped: put the kind variables into + -- scopedSort: put the kind variables into -- well-scoped order. -- E.g. [k, (a::k)] not the other way roud @@ -1427,7 +1453,7 @@ -- This block uses level numbers to decide what to quantify -- and emits a warning if the two methods do not give the same answer - ; let dep_kvs2 = dVarSetElemsWellScoped $ + ; let dep_kvs2 = scopedSort $ dVarSetElems $ filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs nondep_tvs2 = filter (quantifiableTv outer_tclvl) $ dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs --- a/compiler/typecheck/TcPluginM.hs +++ b/compiler/typecheck/TcPluginM.hs @@ -3,7 +3,7 @@ -- access select functions of the 'TcM', principally those to do with -- reading parts of the state. module TcPluginM ( -#if defined(GHCI) +#if defined(HAVE_INTERPRETER) -- * Basic TcPluginM functionality TcPluginM, tcPluginIO, @@ -52,7 +52,7 @@ #endif ) where -#if defined(GHCI) +#if defined(HAVE_INTERPRETER) import GhcPrelude import qualified TcRnMonad as TcM diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -61,7 +61,6 @@ import RnUtils ( HsDocContext(..) ) import RnFixity ( lookupFixityRn ) import MkId -import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags @@ -141,6 +140,9 @@ import Control.DeepSeq import Control.Monad +import TcHoleFitTypes ( HoleFitPluginR (..) ) + + #include "HsVersions.h" {- @@ -165,7 +167,7 @@ (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ + withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ tcRnModuleTcRnM hsc_env mod_sum parsedModule pair @@ -1841,7 +1843,7 @@ -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) @@ -2418,10 +2420,11 @@ -- tcRnType just finds the kind of a type tcRnType :: HscEnv + -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs -> IO (Messages, Maybe (Type, Kind)) -tcRnType hsc_env normalise rdr_type +tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs) @@ -2434,18 +2437,21 @@ -- It can have any rank or kind -- First bring into scope any wildcards ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; ((ty, kind), lie) <- - captureTopConstraints $ - tcWildCardBinders wcs $ \ wcs' -> - do { emitWildCardHoleConstraints wcs' + ; (ty, kind) <- pushTcLevelM_ $ + -- must push level to satisfy level precondition of + -- kindGeneralize, below + solveEqualities $ + tcNamedWildCardBinders wcs $ \ wcs' -> + do { emitNamedWildCardHoleConstraints wcs' ; tcLHsTypeUnsaturated rn_type } - ; _ <- checkNoErrs (simplifyInteractive lie) -- Do kind generalisation; see Note [Kind-generalise in tcRnType] ; kind <- zonkTcType kind ; kvs <- kindGeneralize kind - ; ty <- zonkTcTypeToType ty + ; e <- mkEmptyZonkEnv flexi + ; ty <- zonkTcTypeToTypeX e ty + -- Do validity checking on type ; checkValidType (GhciCtxt True) ty @@ -2556,7 +2562,9 @@ externaliseAndTidyId :: Module -> Id -> TcM Id externaliseAndTidyId this_mod id = do { name' <- externaliseName this_mod (idName id) - ; return (globaliseAndTidyId (setIdName id name')) } + ; return $ globaliseId id + `setIdName` name' + `setIdType` tidyTopType (idType id) } {- @@ -2874,6 +2882,30 @@ getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin] getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) + + +withHoleFitPlugins :: HscEnv -> TcM a -> TcM a +withHoleFitPlugins hsc_env m = + case (getHfPlugins (hsc_dflags hsc_env)) of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins + -- This ensures that hfPluginStop is called even if a type + -- error occurs during compilation. + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m + sequence_ stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + startPlugin (HoleFitPluginR init plugin stop) = + do ref <- init + return (plugin ref, stop ref) + +getHfPlugins :: DynFlags -> [HoleFitPluginR] +getHfPlugins dflags = + catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args) + runRenamerPlugin :: TcGblEnv -> HsGroup GhcRn diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -75,7 +75,6 @@ askNoErrs, discardErrs, tryTcDiscardingErrs, checkNoErrs, whenNoErrs, ifErrsM, failIfErrsM, - checkTH, failTH, -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, @@ -104,7 +103,8 @@ pushTcLevelM_, pushTcLevelM, pushTcLevelsM, getTcLevel, setTcLevel, isTouchableTcM, getLclTypeEnv, setLclTypeEnv, - traceTcConstraints, emitWildCardHoleConstraints, + traceTcConstraints, + emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, -- * Template Haskell context recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc, @@ -312,6 +312,7 @@ tcg_safeInfer = infer_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], + tcg_hf_plugins = [], tcg_top_loc = loc, tcg_static_wc = static_wc_var, tcg_complete_matches = [], @@ -1021,17 +1022,6 @@ -- Useful to avoid error cascades failIfErrsM = ifErrsM failM (return ()) -checkTH :: a -> String -> TcRn () -checkTH _ _ = return () -- OK - -failTH :: Outputable a => a -> String -> TcRn x -failTH e what -- Raise an error in a stage-1 compiler - = failWithTc (vcat [ hang (char 'A' <+> text what - <+> text "requires GHC with interpreter support:") - 2 (ppr e) - , text "Perhaps you are using a stage-1 compiler?" ]) - - {- ********************************************************************* * * Context management for the type checker @@ -1688,9 +1678,17 @@ hang (text (msg ++ ": LIE:")) 2 (ppr lie) } -emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitWildCardHoleConstraints wcs +emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () +emitAnonWildCardHoleConstraint tv = do { ct_loc <- getCtLocM HoleOrigin Nothing + ; emitInsolubles $ unitBag $ + CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv + , ctev_loc = ct_loc } + , cc_hole = TypeHole (mkTyVarOcc "_") } } + +emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () +emitNamedWildCardHoleConstraints wcs + = do { ct_loc <- getCtLocM HoleOrigin Nothing ; emitInsolubles $ listToBag $ map (do_one ct_loc) wcs } where @@ -1702,7 +1700,7 @@ where real_span = case nameSrcSpan name of RealSrcSpan span -> span - UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints" + UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" (ppr name <+> quotes (ftext str)) -- Wildcards are defined locally, and so have RealSrcSpans ct_loc' = setCtLocSpan ct_loc real_span @@ -1837,13 +1835,13 @@ finalSafeMode dflags tcg_env = do safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) return $ case safeHaskell dflags of - Sf_None | safeInferOn dflags && safeInf -> Sf_Safe + Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred | otherwise -> Sf_None s -> s -- | Switch instances to safe instances if we're in Safe mode. fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] -fixSafeInstances sfMode | sfMode /= Sf_Safe = id +fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id fixSafeInstances _ = map fixSafe where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } in inst { is_flag = new_flag } diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} -- Type definitions for the constraint solver module TcSMonad ( @@ -33,8 +33,10 @@ MaybeNew(..), freshGoals, isFresh, getEvExpr, newTcEvBinds, newNoTcEvBinds, - newWantedEq, emitNewWantedEq, - newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC, + newWantedEq, newWantedEq_SI, emitNewWantedEq, + newWanted, newWanted_SI, newWantedEvVar, + newWantedNC, newWantedEvVarNC, + newDerivedNC, newBoundEvVarId, unifyTyVar, unflattenFmv, reportUnifications, setEvBind, setWantedEq, @@ -2599,10 +2601,7 @@ } --------------- -newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } - -instance Functor TcS where - fmap f m = TcS $ fmap f . unTcS m +newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) instance Applicative TcS where pure x = TcS (\_ -> return x) @@ -3404,12 +3403,18 @@ ; return co } -- | Make a new equality CtEvidence -newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion) -newWantedEq loc role ty1 ty2 +newWantedEq :: CtLoc -> Role -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq = newWantedEq_SI WDeriv + +newWantedEq_SI :: ShadowInfo -> CtLoc -> Role + -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq_SI si loc role ty1 ty2 = do { hole <- wrapTcS $ TcM.newCoercionHole pty ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv + , ctev_nosh = si , ctev_loc = loc} , mkHoleCo hole ) } where @@ -3417,35 +3422,44 @@ -- no equalities here. Use newWantedEq instead newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence +newWantedEvVarNC = newWantedEvVarNC_SI WDeriv + +newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence -- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC loc pty +newWantedEvVarNC_SI si loc pty = do { new_ev <- newEvVar pty ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ pprCtLoc loc) ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev - , ctev_nosh = WDeriv + , ctev_nosh = si , ctev_loc = loc })} newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew +newWantedEvVar = newWantedEvVar_SI WDeriv + +newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew -- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar loc pty +newWantedEvVar_SI si loc pty = do { mb_ct <- lookupInInerts loc pty ; case mb_ct of Just ctev | not (isDerived ctev) -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC loc pty + _ -> do { ctev <- newWantedEvVarNC_SI si loc pty ; return (Fresh ctev) } } --- deals with both equalities and non equalities. Tries to look --- up non-equalities in the cache newWanted :: CtLoc -> PredType -> TcS MaybeNew -newWanted loc pty +-- Deals with both equalities and non equalities. Tries to look +-- up non-equalities in the cache +newWanted = newWanted_SI WDeriv + +newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew +newWanted_SI si loc pty | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq loc role ty1 ty2 + = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2 | otherwise - = newWantedEvVar loc pty + = newWantedEvVar_SI si loc pty -- deals with both equalities and non equalities. Doesn't do any cache lookups. newWantedNC :: CtLoc -> PredType -> TcS CtEvidence diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -498,25 +498,14 @@ , sig_loc = loc }) = setSrcSpan loc $ -- Set the binding site of the tyvars do { traceTc "Staring partial sig {" (ppr hs_sig) - ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty - - -- Clone the quantified tyvars - -- Reason: we might have f, g :: forall a. a -> _ -> a - -- and we want it to behave exactly as if there were - -- two separate signatures. Cloning here seems like - -- the easiest way to do so, and is very similar to - -- the tcInstType in the CompleteSig case - -- See #14643 - ; (subst, tvs') <- newMetaTyVarTyVars tvs - -- Why newMetaTyVarTyVars? See TcBinds - -- Note [Quantified variables in partial type signatures] - ; let tv_prs = tv_names `zip` tvs' - inst_sig = TISI { sig_inst_sig = hs_sig + ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty + -- See Note [Checking partial type signatures] in TcHsType + ; let inst_sig = TISI { sig_inst_sig = hs_sig , sig_inst_skols = tv_prs , sig_inst_wcs = wcs , sig_inst_wcx = wcx - , sig_inst_theta = substTysUnchecked subst theta - , sig_inst_tau = substTyUnchecked subst tau } + , sig_inst_theta = theta + , sig_inst_tau = tau } ; traceTc "End partial sig }" (ppr inst_sig) ; return inst_sig } diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -30,9 +30,7 @@ import Bag import Class ( Class, classKey, classTyCon ) -import DynFlags ( WarningFlag ( Opt_WarnMonomorphism ) - , WarnReason ( Reason ) - , DynFlags( solverIterations ) ) +import DynFlags import HsExpr ( UnboundVar(..) ) import Id ( idType, mkLocalId ) import Inst @@ -169,10 +167,11 @@ ; emitConstraints wanted -- See Note [Fail fast if there are insoluble kind equalities] - ; if insolubleWC wanted - then failM - else return res } + ; when (insolubleWC wanted) $ + failM + ; return res } + {- Note [Fail fast if there are insoluble kind equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Rather like in simplifyInfer, fail fast if there is an insoluble @@ -228,12 +227,16 @@ simpl_top wanteds = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) -- This is where the main work happens - ; try_tyvar_defaulting wc_first_go } + ; dflags <- getDynFlags + ; try_tyvar_defaulting dflags wc_first_go } where - try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints - try_tyvar_defaulting wc + try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints + try_tyvar_defaulting dflags wc | isEmptyWC wc = return wc + | insolubleWC wc + , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] + = try_class_defaulting wc | otherwise = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs @@ -251,7 +254,7 @@ try_class_defaulting :: WantedConstraints -> TcS WantedConstraints try_class_defaulting wc - | isEmptyWC wc + | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] = return wc | otherwise -- See Note [When to do type-class defaulting] = do { something_happened <- applyDefaultingRules wc @@ -517,6 +520,50 @@ This is ambiguous of course, but we don't want to default the (Num alpha) constraint to (Num Int)! Doing so gives a defaulting warning, but no error. + +Note [Defaulting insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a set of wanteds is insoluble, we have no hope of accepting the +program. Yet we do not stop constraint solving, etc., because we may +simplify the wanteds to produce better error messages. So, once +we have an insoluble constraint, everything we do is just about producing +helpful error messages. + +Should we default in this case or not? Let's look at an example (tcfail004): + + (f,g) = (1,2,3) + +With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). +Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) +find the latter more helpful. Several other test cases (e.g. tcfail005) suggest +similarly. So: we should not do class defaulting with insolubles. + +On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: + + f :: Integer i => i + f = 0 + +Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind +TYPE r0 -> Constraint and then complains that r0 is actually untouchable +(presumably, because it can't be sure if `Integer i` entails an equality). +If we default, we are told of a clash between (* -> Constraint) and Constraint. +The latter seems far better, suggesting we *should* do RuntimeRep-defaulting +even on insolubles. + +But, evidently, not always. Witness UnliftedNewtypesInfinite: + + newtype Foo = FooC (# Int#, Foo #) + +This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). +If we default RuntimeRep-vars, we get + + Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted + +which is just plain wrong. + +Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not +want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps +is not set. -} ------------------ diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -37,6 +37,7 @@ import TcClassDcl import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) import TcDeriv (DerivInfo) +import TcUnify ( unifyKind ) import TcHsType import ClsInst( AssocInstInfo(..) ) import TcMType @@ -568,7 +569,7 @@ -- Running example in Note [Inferring kinds for type declarations] -- spec_req_prs = [ ("k1",kk1), ("a", (aa::kk1)) -- , ("k2",kk2), ("x", (xx::kk2))] - -- where "k1" dnotes the Name k1, and kk1, aa, etc are MetaTyVarss, + -- where "k1" dnotes the Name k1, and kk1, aa, etc are MetaTyVars, -- specifically TyVarTvs -- Step 0: zonk and skolemise the Specified and Required binders @@ -1030,9 +1031,15 @@ , dd_ND = new_or_data } }) = do { let flav = newOrDataToFlavour new_or_data ; tc <- kcLHsQTyVars name flav cusk ktvs $ - case m_sig of - Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig - Nothing -> return liftedTypeKind + -- See Note [Implementation of UnliftedNewtypes] + do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; case m_sig of + Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig + Nothing + | NewType <- new_or_data + , unlifted_newtypes -> newOpenTypeKind + | otherwise -> pure liftedTypeKind + } ; return [tc] } getInitialKind cusk (FamDecl { tcdFam = decl }) @@ -1127,8 +1134,13 @@ kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) , tcdDataDefn = defn }) | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _) - , dd_ctxt = (dL->L _ []) } <- defn - = mapM_ (wrapLocM_ kcConDecl) cons + , dd_ctxt = (dL->L _ []) + , dd_ND = new_or_data } <- defn + = do { tyCon <- kcLookupTcTyCon name + -- See Note [Implementation of UnliftedNewtypes] STEP 2 + ; (_, final_res_kind) <- etaExpandAlgTyCon (tyConBinders tyCon) (tyConResKind tyCon) + ; mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons + } -- hs_tvs and dd_kindSig already dealt with in getInitialKind -- This must be a GADT-style decl, -- (see invariants of DataDefn declaration) @@ -1136,10 +1148,14 @@ -- ConDecls bind all their own variables -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it - | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn + | HsDataDefn { dd_ctxt = ctxt + , dd_cons = cons + , dd_ND = new_or_data } <- defn = bindTyClTyVars name $ \ _ _ -> - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kcConDecl) cons } + do { _ <- tcHsContext ctxt + ; tyCon <- kcLookupTcTyCon name + ; mapM_ (wrapLocM_ (kcConDecl new_or_data (tyConResKind tyCon))) cons + } kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs }) = bindTyClTyVars name $ \ _ res_kind -> @@ -1153,9 +1169,11 @@ do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM_ kc_sig) sigs } where - kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty + kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty kc_sig _ = return () + skol_info = TyConSkol ClassFlavour name + kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't @@ -1170,23 +1188,66 @@ kcTyClDecl (XTyClDecl _) = panic "kcTyClDecl" ------------------- -kcConDecl :: ConDecl GhcRn -> TcM () -kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = ex_ctxt, con_args = args }) + +-- | Unify the kind of the first type provided with the newtype's kind, if +-- -XUnliftedNewtypes is enabled and the NewOrData indicates Newtype. If there +-- is more than one type provided, do nothing: the newtype is in error, and this +-- will be caught in validity checking (which will give a better error than we can +-- here.) +unifyNewtypeKind :: DynFlags + -> NewOrData + -> [LHsType GhcRn] -- user-written argument types, should be just 1 + -> [TcType] -- type-checked argument types, should be just 1 + -> TcKind -- expected kind of newtype + -> TcM [TcType] -- casted argument types (should be just 1) + -- result = orig_arg |> kind_co + -- where kind_co :: orig_arg_ki ~N expected_ki +unifyNewtypeKind dflags NewType [hs_ty] [tc_ty] ki + | xopt LangExt.UnliftedNewtypes dflags + = do { traceTc "unifyNewtypeKind" (ppr hs_ty $$ ppr tc_ty $$ ppr ki) + ; co <- unifyKind (Just (unLoc hs_ty)) (typeKind tc_ty) ki + ; return [tc_ty `mkCastTy` co] } + -- See comments above: just do nothing here +unifyNewtypeKind _ _ _ arg_tys _ = return arg_tys + +-- Type check the types of the arguments to a data constructor. +-- This includes doing kind unification if the type is a newtype. +-- See Note [Implementation of UnliftedNewtypes] for why we need +-- the first two arguments. +kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () +kcConArgTys new_or_data res_kind arg_tys = do + { arg_tc_tys <- mapM (tcHsOpenType . getBangType) arg_tys + -- See Note [Implementation of UnliftedNewtypes], STEP 2 + ; dflags <- getDynFlags + ; discardResult $ + unifyNewtypeKind dflags new_or_data arg_tys arg_tc_tys res_kind + } + +-- Kind check a data constructor. In additional to the data constructor, +-- we also need to know about whether or not its corresponding type was +-- declared with data or newtype, and we need to know the result kind of +-- this type. See Note [Implementation of UnliftedNewtypes] for why +-- we need the first two arguments. +kcConDecl :: + NewOrData -- Was the corresponding type declared with data or newtype? + -> Kind -- The result kind of the corresponding type constructor + -> ConDecl GhcRn -- The data constructor + -> TcM () +kcConDecl new_or_data res_kind (ConDeclH98 + { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = ex_ctxt, con_args = args }) = addErrCtxt (dataConCtxtName [name]) $ discardResult $ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsMbContext ex_ctxt - ; traceTc "kcConDecl {" (ppr name $$ ppr args) - ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) - ; traceTc "kcConDecl }" (ppr name) + ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + -- We don't need to check the telescope here, because that's + -- done in tcConDecl } - -- We don't need to check the telescope here, because that's - -- done in tcConDecl -kcConDecl (ConDeclGADT { con_names = names - , con_qvars = qtvs, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty }) +kcConDecl new_or_data res_kind (ConDeclGADT + { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt + , con_args = args, con_res_ty = res_ty }) | HsQTvs { hsq_ext = implicit_tkv_nms , hsq_explicit = explicit_tkv_nms } <- qtvs = -- Even though the data constructor's type is closed, we @@ -1202,11 +1263,11 @@ bindExplicitTKBndrs_Tv explicit_tkv_nms $ -- Why "_Tv"? See Note [Kind-checking for GADTs] do { _ <- tcHsMbContext cxt - ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) + ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) ; _ <- tcHsOpenType res_ty ; return () } -kcConDecl (XConDecl _) = panic "kcConDecl" -kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl" +kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl" +kcConDecl _ _ (XConDecl _) = panic "kcConDecl" {- Note [Recursion and promoting data constructors] @@ -1352,6 +1413,112 @@ and take the wired-in information. That avoids complications. e.g. the need to make the data constructor worker name for a constraint tuple match the wired-in one + +Note [Implementation of UnliftedNewtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedNewtypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 + +What follows is a high-level overview of the implementation of the +proposal. + +STEP 1: Getting the initial kind, as done by getInitialKind. We have +two sub-cases (assuming we have a newtype and -XUnliftedNewtypes is enabled): + +* With a CUSK: no change in kind-checking; the tycon is given the kind + the user writes, whatever it may be. + +* Without a CUSK: If there is no kind signature, the tycon is given + a kind `TYPE r`, for a fresh unification variable `r`. + +STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. +The key function here is kcConDecl, which looks at an individual constructor +declaration. In the unlifted-newtypes case (i.e., -XUnliftedNewtypes and, +indeed, we are processing a newtype), we call unifyNewtypeKind, which is a +thin wrapper around unifyKind, unifying the kind of the one argument and the +result kind of the newtype tycon. + +Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is +enabled (we use r0 to denote a unification variable): + +newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) ++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) + is the kind that getInitialKind invented for (Foo rep). + +data Color = Red | Blue +type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep +data family Foo (x :: Color) :: TYPE (Interpret x) +newtype instance Foo 'Red = FooRedC Int# ++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep + +Note that, in the GADT case, we might have a kind signature with arrows +(newtype XYZ a b :: Type -> Type where ...). We want only the final +component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon +in kcTyClDecl. + +STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function +here is tcConDecl. Once again, we must call unifyNewtypeKind, for two reasons: + + A. It is possible that a GADT has a CUSK. (Note that this is *not* + possible for H98 types. Recall that CUSK types don't go through + kcTyClDecl, so we might not have done this kind check. + B. We need to produce the coercion to put on the argument type + if the kinds are different (for both H98 and GADT). + +Example of (B): + +type family F a where + F Int = LiftedRep + +newtype N :: TYPE (F Int) where + MkN :: Int -> N + +We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where +axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the +newtype kind, which is the principal correctness condition for newtypes. +This call to unifyNewtypeKind is what produces that coercion. + +Note that this is possible in the H98 case only for a data family, because +the H98 syntax doesn't permit a kind signature on the newtype itself. + + +1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if + UnliftedNewtypes is on. This allows us to write things like: + data family Foo :: TYPE 'IntRep + +2. In a newtype instance (with -XUnliftedNewtypes), if the user does + not write a kind signature, we want to allow the possibility that + the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. + This is done in tcDataFamHeader in TcInstDcls. Example: + + data family Bar (a :: RuntimeRep) :: TYPE a + newtype instance Bar 'IntRep = BarIntC Int# + newtype instance Bar 'WordRep :: TYPE 'WordRep where + BarWordC :: Word# -> Bar 'WordRep + + The data instance corresponding to IntRep does not specify a kind signature, + so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). + The data instance corresponding to WordRep does have a kind signature, so + we use that kind signature. + +3. A data family and its newtype instance may be declared with slightly + different kinds. See Note [Unifying data family kinds] in TcInstDcls. + +There's also a change in the renamer: + +* In RnSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means + for a newtype to have a CUSK. This is necessary since UnliftedNewtypes + means that, for newtypes without kind signatures, we must use the field + inside the data constructor to determine the result kind. + See Note [Unlifted Newtypes and CUSKs] for more detail. + +For completeness, it was also neccessary to make coerce work on +unlifted types, resolving #13595. + -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon @@ -1707,11 +1874,10 @@ -- Type or a kind-variable -- For the latter, consider -- data family D a :: forall k. Type -> k + -- When UnliftedNewtypes is enabled, we loosen this restriction + -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). ; let (_, final_res_kind) = splitPiTys res_kind - ; checkTc (tcIsLiftedTypeKind final_res_kind - || isJust (tcGetCastedTyVar_maybe final_res_kind)) - (badKindSig False res_kind) - + ; checkDataKindSig DataFamilySort final_res_kind ; tc_rep_name <- newTyConRepName tc_name ; let tycon = mkFamilyTyCon tc_name binders res_kind @@ -1858,10 +2024,9 @@ ; tcg_env <- getGblEnv ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind - ; let hsc_src = tcg_src tcg_env ; unless (mk_permissive_kind hsc_src cons) $ - checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind) + checkDataKindSig (DataDeclSort new_or_data) final_res_kind ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta @@ -1875,8 +2040,13 @@ { let final_bndrs = tycon_binders `chkAppend` extra_bndrs res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) roles = roles_info tc_name - - ; data_cons <- tcConDecls tycon final_bndrs res_ty cons + ; data_cons <- tcConDecls + tycon + new_or_data + final_bndrs + final_res_kind + res_ty + cons ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name ; return (mkAlgTyCon tc_name @@ -1892,7 +2062,12 @@ where -- Abstract data types in hsig files can have arbitrary kinds, -- because they may be implemented by type synonyms - -- (which themselves can have arbitrary kinds, not just *) + -- (which themselves can have arbitrary kinds, not just *). See #13955. + -- + -- Note that this is only a property that data type declarations possess, + -- so one could not have, say, a data family instance in an hsig file that + -- has kind `Bool`. Therfore, this check need only occur in the code that + -- typechecks data type declarations. mk_permissive_kind HsigFile [] = True mk_permissive_kind _ _ = False @@ -1974,11 +2149,9 @@ vis_pats = numVisibleArgs hs_pats ; checkTc (vis_pats == vis_arity) $ wrongNumberOfParmsErr vis_arity - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars (mb_expl_bndrs `orElse` []) hs_pats hs_rhs_ty - -- Don't print results they may be knot-tied -- (tcFamInstEqnGuts zonks to Type) ; return (mkCoAxBranch qtvs [] [] pats rhs_ty @@ -2013,7 +2186,7 @@ So, the kind-checker must return the new skolems and args (that is, Type or (Type -> Type) for the equations above) and the instantiated kind. -Note [Generalising in tcFamTyPatsGuts] +Note [Generalising in tcTyFamInstEqnGuts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have something like type instance forall (a::k) b. F t1 t2 = rhs @@ -2071,7 +2244,7 @@ ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind ; return (lhs_ty, rhs_ty) } - -- See Note [Generalising in tcFamTyPatsGuts] + -- See Note [Generalising in tcTyFamInstEqnGuts] -- This code (and the stuff immediately above) is very similar -- to that in tcDataFamHeader. Maybe we should abstract the -- common code; but for the moment I concluded that it's @@ -2128,15 +2301,12 @@ unravelFamInstPats fam_app = case splitTyConApp_maybe fam_app of Just (_, pats) -> pats - Nothing -> WARN( True, bad_lhs fam_app ) [] + Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" -- The Nothing case cannot happen for type families, because -- we don't call unravelFamInstPats until we've solved the - -- equalities. For data families I wasn't quite as convinced - -- so I've let it as a warning rather than a panic. - where - bad_lhs fam_app - = hang (text "Ill-typed LHS of family instance") - 2 (debugPprType fam_app) + -- equalities. For data families, it shouldn't happen either, + -- we need to fail hard and early if it does. See trac issue #15905 + -- for an example of this happening. addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () -- In the corresponding positions of the class and type-family, @@ -2293,25 +2463,26 @@ -- All constructors have same shape ----------------------------------- -tcConDecls :: KnotTied TyCon -> [KnotTied TyConBinder] -> KnotTied Type - -> [LConDecl GhcRn] -> TcM [DataCon] - -- Why both the tycon tyvars and binders? Because the tyvars - -- have all the names and the binders have the visibilities. -tcConDecls rep_tycon tmpl_bndrs res_tmpl +tcConDecls :: KnotTied TyCon -> NewOrData + -> [TyConBinder] -> TcKind -- binders and result kind of tycon + -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon] +tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl = concatMapM $ addLocM $ - tcConDecl rep_tycon (mkTyConTagMap rep_tycon) tmpl_bndrs res_tmpl + tcConDecl rep_tycon (mkTyConTagMap rep_tycon) + tmpl_bndrs res_kind res_tmpl new_or_data -- It's important that we pay for tag allocation here, once per TyCon, -- See Note [Constructor tag allocation], fixes #14657 tcConDecl :: KnotTied TyCon -- Representation tycon. Knot-tied! -> NameEnv ConTag - -> [KnotTied TyConBinder] -> KnotTied Type - -- Return type template (with its template tyvars) - -- (tvs, T tys), where T is the family TyCon + -> [TyConBinder] -> TcKind -- tycon binders and result kind + -> KnotTied Type + -- Return type template (T tys), where T is the family TyCon + -> NewOrData -> ConDecl GhcRn -> TcM [DataCon] -tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl +tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data (ConDeclH98 { con_name = name , con_ex_tvs = explicit_tkv_nms , con_mb_cxt = hs_ctxt @@ -2335,7 +2506,12 @@ ; btys <- tcConArgs hs_args ; field_lbls <- lookupConstructorFields (unLoc name) ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, field_lbls, stricts) + ; dflags <- getDynFlags + ; final_arg_tys <- + unifyNewtypeKind dflags new_or_data + (hsConDeclArgTys hs_args) + arg_tys res_kind + ; return (ctxt, final_arg_tys, field_lbls, stricts) } -- exp_tvs have explicit, user-written binding sites @@ -2391,7 +2567,9 @@ ; mapM buildOneDataCon [name] } -tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl +tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data + -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get + -- the res_kind by typechecking the result type. (ConDeclGADT { con_names = names , con_qvars = qtvs , con_mb_cxt = cxt, con_args = hs_args @@ -2410,13 +2588,19 @@ bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext cxt ; btys <- tcConArgs hs_args - ; res_ty <- tcHsLiftedType hs_res_ty - ; field_lbls <- lookupConstructorFields name ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + ; res_ty <- tcHsOpenType hs_res_ty + -- See Note [Implementation of UnliftedNewtypes] + ; dflags <- getDynFlags + ; final_arg_tys <- + unifyNewtypeKind dflags new_or_data + (hsConDeclArgTys hs_args) + arg_tys (typeKind res_ty) + ; field_lbls <- lookupConstructorFields name + ; return (ctxt, final_arg_tys, res_ty, field_lbls, stricts) } ; imp_tvs <- zonkAndScopedSort imp_tvs - ; let user_tvs = imp_tvs ++ exp_tvs + ; let user_tvs = imp_tvs ++ exp_tvs ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $ mkPhiTy ctxt $ @@ -2469,9 +2653,9 @@ ; traceTc "tcConDecl 2" (ppr names) ; mapM buildOneDataCon names } -tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) +tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "tcConDecl" -tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl" +tcConDecl _ _ _ _ _ _ (XConDecl _) = panic "tcConDecl" tcConIsInfixH98 :: Name -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) @@ -2578,11 +2762,10 @@ rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. -- data instance T [a] b c ... -- gives template ([a,b,c], T [a] b c) - -- Type must be of kind *! -> [TyVar] -- The constructor's inferred type variables -> [TyVar] -- The constructor's user-written, specified -- type variables - -> KnotTied Type -- res_ty type must be of kind * + -> KnotTied Type -- res_ty -> ([TyVar], -- Universal [TyVar], -- Existential (distinct OccNames from univs) [TyVar], -- The constructor's rejigged, user-written, @@ -2611,9 +2794,7 @@ -- So we return ( [a,b,z], [x,y] -- , [], [x,y,z] -- , [a~(x,y),b~z], ) - | Just subst <- ASSERT( isLiftedTypeKind (tcTypeKind res_ty) ) - ASSERT( isLiftedTypeKind (tcTypeKind res_tmpl) ) - tcMatchTy res_tmpl res_ty + | Just subst <- tcMatchTy res_tmpl res_ty = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst raw_ex_tvs = dc_tvs `minusList` univ_tvs (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs @@ -3151,9 +3332,14 @@ -- Check all argument types for validity ; checkValidType ctxt (dataConUserType con) - ; mapM_ (checkForLevPoly empty) - (dataConOrigArgTys con) + -- If we are dealing with a newtype, we allow levity polymorphism + -- regardless of whether or not UnliftedNewtypes is enabled. A + -- later check in checkNewDataCon handles this, producing a + -- better error message than checkForLevPoly would. + ; unless (isNewTyCon tc) + (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) + -- Extra checks for newtype data constructors ; when (isNewTyCon tc) (checkNewDataCon con) @@ -3235,8 +3421,13 @@ = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) -- One argument - ; checkTc (not (isUnliftedType arg_ty1)) $ - text "A newtype cannot have an unlifted argument type" + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let allowedArgType = + unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True + ; checkTc allowedArgType $ vcat + [ text "A newtype cannot have an unlifted argument type" + , text "Perhaps you intended to use UnliftedNewtypes" + ] ; check_con (null eq_spec) $ text "A newtype constructor must have a return type of form T a1 ... an" diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -10,6 +10,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -149,12 +150,10 @@ -- a failure message reporting that a cycle was found. newtype SynCycleM a = SynCycleM { runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } + deriving (Functor) type SynCycleState = NameSet -instance Functor SynCycleM where - fmap = liftM - instance Applicative SynCycleM where pure x = SynCycleM $ \state -> Right (x, state) (<*>) = ap @@ -677,9 +676,7 @@ -> Int -- size of VarPositions -> RoleInferenceState -> (a, RoleInferenceState) } - -instance Functor RoleM where - fmap = liftM + deriving (Functor) instance Applicative RoleM where pure x = RM $ \_ _ _ state -> (x, state) diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -21,6 +21,7 @@ import TcEnv import TcEvidence ( mkWpTyApps ) import TcRnMonad +import TcTypeableValidity import HscTypes ( lookupId ) import PrelNames import TysPrim ( primTyCons ) @@ -45,7 +46,6 @@ import Control.Monad.Trans.State import Control.Monad.Trans.Class (lift) -import Data.Maybe ( isJust ) import Data.Word( Word64 ) {- Note [Grand plan for Typeable] @@ -411,36 +411,6 @@ let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs return $ unitBag tycon_rep_bind - --- | Here is where we define the set of Typeable types. These exclude type --- families and polytypes. -tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && typeIsTypeable (dropForAlls $ tyConKind tc) - -- Ensure that the kind of the TyCon, with its initial foralls removed, - -- is representable (e.g. has no higher-rank polymorphism or type - -- synonyms). - --- | Is a particular 'Type' representable by @Typeable@? Here we look for --- polytypes and types containing casts (which may be, for instance, a type --- family). -typeIsTypeable :: Type -> Bool --- We handle types of the form (TYPE rep) specifically to avoid --- looping on (tyConIsTypeable RuntimeRep) -typeIsTypeable ty - | Just ty' <- coreView ty = typeIsTypeable ty' -typeIsTypeable ty - | isJust (kindRep_maybe ty) = True -typeIsTypeable (TyVarTy _) = True -typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b -typeIsTypeable (FunTy _ a b) = typeIsTypeable a && typeIsTypeable b -typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc - && all typeIsTypeable args -typeIsTypeable (ForAllTy{}) = False -typeIsTypeable (LitTy _) = True -typeIsTypeable (CastTy{}) = False -typeIsTypeable (CoercionTy{}) = False -- | Maps kinds to 'KindRep' bindings. This binding may either be defined in -- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') diff --git a/compiler/typecheck/TcTypeableValidity.hs b/compiler/typecheck/TcTypeableValidity.hs new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcTypeableValidity.hs @@ -0,0 +1,46 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + +-- | This module is separate from "TcTypeable" because the functions in this +-- module are used in "ClsInst", and importing "TcTypeable" from "ClsInst" +-- would lead to an import cycle. +module TcTypeableValidity (tyConIsTypeable, typeIsTypeable) where + +import GhcPrelude + +import TyCoRep +import TyCon +import Type + +import Data.Maybe (isJust) + +-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type +-- families and polytypes. +tyConIsTypeable :: TyCon -> Bool +tyConIsTypeable tc = + isJust (tyConRepName_maybe tc) + && typeIsTypeable (dropForAlls $ tyConKind tc) + +-- | Is a particular 'Type' representable by @Typeable@? Here we look for +-- polytypes and types containing casts (which may be, for instance, a type +-- family). +typeIsTypeable :: Type -> Bool +-- We handle types of the form (TYPE LiftedRep) specifically to avoid +-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) +-- to be typeable without inspecting rr, but this exhibits bad behavior +-- when rr is a type family. +typeIsTypeable ty + | Just ty' <- coreView ty = typeIsTypeable ty' +typeIsTypeable ty + | isLiftedTypeKind ty = True +typeIsTypeable (TyVarTy _) = True +typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b +typeIsTypeable (FunTy _ a b) = typeIsTypeable a && typeIsTypeable b +typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc + && all typeIsTypeable args +typeIsTypeable (ForAllTy{}) = False +typeIsTypeable (LitTy _) = True +typeIsTypeable (CastTy{}) = False +typeIsTypeable (CoercionTy{}) = False diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -6,7 +6,8 @@ Type subsumption and unification -} -{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, + ScopedTypeVariables #-} module TcUnify ( -- Full-blown subsumption @@ -2119,9 +2120,7 @@ = MTVU_OK a | MTVU_Bad -- Forall, predicate, or type family | MTVU_Occurs - -instance Functor MetaTyVarUpdateResult where - fmap = liftM + deriving (Functor) instance Applicative MetaTyVarUpdateResult where pure = MTVU_OK diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs --- a/compiler/utils/AsmUtils.hs +++ b/compiler/utils/AsmUtils.hs @@ -8,7 +8,7 @@ import GhcPrelude -import Platform +import GHC.Platform import Outputable -- | Generate a section type (e.g. @\@progbits@). See #13937. diff --git a/compiler/utils/ListT.hs b/compiler/utils/ListT.hs --- a/compiler/utils/ListT.hs +++ b/compiler/utils/ListT.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} @@ -42,6 +43,7 @@ -- layered over another monad 'm' newtype ListT m a = ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r } + deriving (Functor) select :: Monad m => [a] -> ListT m a select xs = foldr (<|>) mzero (map pure xs) @@ -54,9 +56,6 @@ -- failure continuations. runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r runListT = unListT - -instance Functor (ListT f) where - fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk instance Applicative (ListT f) where pure a = ListT $ \sk fk -> sk a fk diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs --- a/compiler/utils/State.hs +++ b/compiler/utils/State.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UnboxedTuples #-} module State where @@ -5,10 +6,7 @@ import GhcPrelude newtype State s a = State { runState' :: s -> (# a, s #) } - -instance Functor (State s) where - fmap f m = State $ \s -> case runState' m s of - (# r, s' #) -> (# f r, s' #) + deriving (Functor) instance Applicative (State s) where pure x = State $ \s -> (# x, s #) diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20190603 +version: 0.20190703 license: BSD3 license-file: LICENSE category: Development @@ -41,6 +41,7 @@ ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl + ghc-lib/stage0/compiler/build/Fingerprint.hs includes/*.h includes/CodeGen.Platform.hs includes/rts/*.h @@ -59,12 +60,13 @@ default-extensions: NoImplicitPrelude include-dirs: ghc-lib/generated + ghc-lib/stage0/compiler/build ghc-lib/stage1/compiler/build compiler compiler/utils ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS - cpp-options: -DSTAGE=2 -DTHREADED_RTS -DGHCI -DGHC_IN_GHCI + cpp-options: -DSTAGE=2 -DTHREADED_RTS -DHAVE_INTERPRETER -DGHC_IN_GHCI if !os(windows) build-depends: unix else @@ -84,7 +86,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*, - ghc-lib-parser == 0.20190603 + ghc-lib-parser == 0.20190703 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -120,33 +122,35 @@ UnboxedTuples UndecidableInstances hs-source-dirs: - compiler + ghc-lib/stage0/libraries/ghci/build + ghc-lib/stage0/compiler/build + ghc-lib/stage1/compiler/build + libraries/template-haskell + compiler/specialise + libraries/ghc-boot + compiler/nativeGen + compiler/profiling + compiler/simplCore + compiler/typecheck compiler/backpack - compiler/cmm + compiler/simplStg compiler/codeGen compiler/coreSyn compiler/deSugar - compiler/ghci compiler/hieFile - compiler/hsSyn - compiler/iface compiler/llvmGen - compiler/main - compiler/nativeGen compiler/prelude - compiler/profiling + compiler/stranal compiler/rename - compiler/simplCore - compiler/simplStg - compiler/specialise compiler/stgSyn - compiler/stranal - compiler/typecheck - compiler/utils - ghc-lib/stage1/compiler/build - libraries/ghc-boot libraries/ghci - libraries/template-haskell + compiler/hsSyn + compiler/iface + compiler/utils + compiler/ghci + compiler/main + compiler/cmm + compiler autogen-modules: Paths_ghc_lib reexported-modules: @@ -206,6 +210,7 @@ Fingerprint, FiniteMap, ForeignCall, + GHC.BaseDir, GHC.Exts.Heap, GHC.Exts.Heap.ClosureTypes, GHC.Exts.Heap.Closures, @@ -220,6 +225,7 @@ GHC.LanguageExtensions.Type, GHC.Lexeme, GHC.PackageDb, + GHC.Platform, GHC.Serialized, GHCi.BreakArray, GHCi.FFI, @@ -291,7 +297,6 @@ PipelineMonad, PlaceHolder, PlainPanic, - Platform, PlatformConstants, Plugins, PmExpr, @@ -312,6 +317,7 @@ SysTools.BaseDir, SysTools.Terminal, TcEvidence, + TcHoleFitTypes, TcRnTypes, TcType, ToIface, @@ -426,6 +432,7 @@ FunDeps GHC GHC.HandleEncoding + GHC.Settings GHCi GHCi.BinaryArray GHCi.CreateBCO @@ -490,6 +497,7 @@ PPC.Ppr PPC.RegInfo PPC.Regs + PmPpr PprBase PprC PprCmm @@ -642,6 +650,7 @@ TcTyDecls TcTypeNats TcTypeable + TcTypeableValidity TcUnify TcValidity TidyPgm @@ -671,7 +680,7 @@ hs-source-dirs: ghc ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS - cpp-options: -DGHCI -DTHREADED_RTS -DGHC_LOADED_INTO_GHCI + cpp-options: -DHAVE_INTERPRETER -DTHREADED_RTS -DGHC_LOADED_INTO_GHCI other-modules: GHCi.Leak GHCi.UI diff --git a/ghc-lib/generated/ghcautoconf.h b/ghc-lib/generated/ghcautoconf.h --- a/ghc-lib/generated/ghcautoconf.h +++ b/ghc-lib/generated/ghcautoconf.h @@ -1,4 +1,4 @@ -#ifndef __GHCAUTOCONF_H__ +#if !defined(__GHCAUTOCONF_H__) #define __GHCAUTOCONF_H__ /* mk/config.h. Generated from config.h.in by configure. */ /* mk/config.h.in. Generated from configure.ac by autoheader. */ @@ -526,7 +526,7 @@ /* #undef pid_t */ /* The supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION (7,0) +#define sUPPORTED_LLVM_VERSION (7) /* Define to `unsigned int' if does not define. */ /* #undef size_t */ diff --git a/ghc-lib/generated/ghcplatform.h b/ghc-lib/generated/ghcplatform.h --- a/ghc-lib/generated/ghcplatform.h +++ b/ghc-lib/generated/ghcplatform.h @@ -1,4 +1,4 @@ -#ifndef __GHCPLATFORM_H__ +#if !defined(__GHCPLATFORM_H__) #define __GHCPLATFORM_H__ #define BuildPlatform_TYPE x86_64_apple_darwin diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -1,12 +1,12 @@ -#ifndef __GHCVERSION_H__ +#if !defined(__GHCVERSION_H__) #define __GHCVERSION_H__ -#ifndef __GLASGOW_HASKELL__ +#if !defined(__GLASGOW_HASKELL__) # define __GLASGOW_HASKELL__ 809 #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190603 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190703 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/compiler/build/Fingerprint.hs b/ghc-lib/stage0/compiler/build/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/compiler/build/Fingerprint.hs @@ -0,0 +1,48 @@ +{-# LINE 1 "compiler/utils/Fingerprint.hsc" #-} +{-# LANGUAGE CPP #-} + +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning. +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- ---------------------------------------------------------------------------- + +module Fingerprint ( + readHexFingerprint, + fingerprintByteString, + -- * Re-exported from GHC.Fingerprint + Fingerprint(..), fingerprint0, + fingerprintFingerprints, + fingerprintData, + fingerprintString, + getFileHash + ) where + + +#include "HsVersions.h" + +import GhcPrelude + +import Foreign +import GHC.IO +import Numeric ( readHex ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import GHC.Fingerprint + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafeDupablePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs b/ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs @@ -0,0 +1,377 @@ +{-# LINE 1 "libraries/ghci/GHCi/InfoTable.hsc" #-} +{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} + +-- Get definitions for the structs, constants & config etc. + + +-- | +-- Run-time info table support. This module provides support for +-- creating and reading info tables /in the running program/. +-- We use the RTS data structures directly via hsc2hs. +-- +module GHCi.InfoTable + ( + +{-# LINE 14 "libraries/ghci/GHCi/InfoTable.hsc" #-} + mkConInfoTable + +{-# LINE 16 "libraries/ghci/GHCi/InfoTable.hsc" #-} + ) where + +import Prelude -- See note [Why do we import Prelude here?] + +{-# LINE 20 "libraries/ghci/GHCi/InfoTable.hsc" #-} +import Foreign +import Foreign.C +import GHC.Ptr +import GHC.Exts +import GHC.Exts.Heap +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + +{-# LINE 28 "libraries/ghci/GHCi/InfoTable.hsc" #-} + +ghciTablesNextToCode :: Bool + +{-# LINE 31 "libraries/ghci/GHCi/InfoTable.hsc" #-} +ghciTablesNextToCode = True + +{-# LINE 35 "libraries/ghci/GHCi/InfoTable.hsc" #-} + + +{-# LINE 37 "libraries/ghci/GHCi/InfoTable.hsc" #-} +-- NOTE: Must return a pointer acceptable for use in the header of a closure. +-- If tables_next_to_code is enabled, then it must point the the 'code' field. +-- Otherwise, it should point to the start of the StgInfoTable. +mkConInfoTable + :: Int -- ptr words + -> Int -- non-ptr words + -> Int -- constr tag + -> Int -- pointer tag + -> ByteString -- con desc + -> IO (Ptr StgInfoTable) + -- resulting info table is allocated with allocateExec(), and + -- should be freed with freeExec(). + +mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc = + castFunPtrToPtr <$> newExecConItbl itbl con_desc + where + entry_addr = interpConstrEntry !! ptrtag + code' = mkJumpToAddr entry_addr + itbl = StgInfoTable { + entry = if ghciTablesNextToCode + then Nothing + else Just entry_addr, + ptrs = fromIntegral ptr_words, + nptrs = fromIntegral nonptr_words, + tipe = CONSTR, + srtlen = fromIntegral tag, + code = if ghciTablesNextToCode + then Just code' + else Nothing + } + + +-- ----------------------------------------------------------------------------- +-- Building machine code fragments for a constructor's entry code + +funPtrToInt :: FunPtr a -> Int +funPtrToInt (FunPtr a) = I# (addr2Int# a) + +data Arch = ArchSPARC + | ArchPPC + | ArchX86 + | ArchX86_64 + | ArchAlpha + | ArchARM + | ArchARM64 + | ArchPPC64 + | ArchPPC64LE + | ArchUnknown + deriving Show + +platform :: Arch +platform = + +{-# LINE 96 "libraries/ghci/GHCi/InfoTable.hsc" #-} + ArchX86_64 + +{-# LINE 114 "libraries/ghci/GHCi/InfoTable.hsc" #-} + +mkJumpToAddr :: EntryFunPtr -> ItblCodes +mkJumpToAddr a = case platform of + ArchSPARC -> + -- After some consideration, we'll try this, where + -- 0x55555555 stands in for the address to jump to. + -- According to includes/rts/MachRegs.h, %g3 is very + -- likely indeed to be baggable. + -- + -- 0000 07155555 sethi %hi(0x55555555), %g3 + -- 0004 8610E155 or %g3, %lo(0x55555555), %g3 + -- 0008 81C0C000 jmp %g3 + -- 000c 01000000 nop + + let w32 = fromIntegral (funPtrToInt a) + + hi22, lo10 :: Word32 -> Word32 + lo10 x = x .&. 0x3FF + hi22 x = (x `shiftR` 10) .&. 0x3FFFF + + in Right [ 0x07000000 .|. (hi22 w32), + 0x8610E000 .|. (lo10 w32), + 0x81C0C000, + 0x01000000 ] + + ArchPPC -> + -- We'll use r12, for no particular reason. + -- 0xDEADBEEF stands for the address: + -- 3D80DEAD lis r12,0xDEAD + -- 618CBEEF ori r12,r12,0xBEEF + -- 7D8903A6 mtctr r12 + -- 4E800420 bctr + + let w32 = fromIntegral (funPtrToInt a) + hi16 x = (x `shiftR` 16) .&. 0xFFFF + lo16 x = x .&. 0xFFFF + in Right [ 0x3D800000 .|. hi16 w32, + 0x618C0000 .|. lo16 w32, + 0x7D8903A6, 0x4E800420 ] + + ArchX86 -> + -- Let the address to jump to be 0xWWXXYYZZ. + -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax + -- which is + -- B8 ZZ YY XX WW FF E0 + + let w32 = fromIntegral (funPtrToInt a) :: Word32 + insnBytes :: [Word8] + insnBytes + = [0xB8, byte0 w32, byte1 w32, + byte2 w32, byte3 w32, + 0xFF, 0xE0] + in + Left insnBytes + + ArchX86_64 -> + -- Generates: + -- jmpq *.L1(%rip) + -- .align 8 + -- .L1: + -- .quad + -- + -- which looks like: + -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 + -- with addr at 10. + -- + -- We need a full 64-bit pointer (we can't assume the info table is + -- allocated in low memory). Assuming the info pointer is aligned to + -- an 8-byte boundary, the addr will also be aligned. + + let w64 = fromIntegral (funPtrToInt a) :: Word64 + insnBytes :: [Word8] + insnBytes + = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, + byte0 w64, byte1 w64, byte2 w64, byte3 w64, + byte4 w64, byte5 w64, byte6 w64, byte7 w64] + in + Left insnBytes + + ArchAlpha -> + let w64 = fromIntegral (funPtrToInt a) :: Word64 + in Right [ 0xc3800000 -- br at, .+4 + , 0xa79c000c -- ldq at, 12(at) + , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well + , 0x47ff041f -- nop + , fromIntegral (w64 .&. 0x0000FFFF) + , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ] + + ArchARM { } -> + -- Generates Arm sequence, + -- ldr r1, [pc, #0] + -- bx r1 + -- + -- which looks like: + -- 00000000 <.addr-0x8>: + -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr> + -- 4: 11ff2fe1 bx r1 + let w32 = fromIntegral (funPtrToInt a) :: Word32 + in Left [ 0x00, 0x10, 0x9f, 0xe5 + , 0x11, 0xff, 0x2f, 0xe1 + , byte0 w32, byte1 w32, byte2 w32, byte3 w32] + + ArchARM64 { } -> + -- Generates: + -- + -- ldr x1, label + -- br x1 + -- label: + -- .quad + -- + -- which looks like: + -- 0: 58000041 ldr x1,