ghc-lib 0.20190603 → 0.20190703

raw patch · 168 files changed

+5627/−2969 lines, 168 filesdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/cmm/CLabel.hs +2/−3
• compiler/cmm/CmmBuildInfoTables.hs +1/−1
• compiler/cmm/CmmCallConv.hs +26/−16
• compiler/cmm/CmmExpr.hs +62/−21
• compiler/cmm/CmmInfo.hs +1/−1
• compiler/cmm/CmmLint.hs +10/−7
• compiler/cmm/CmmMachOp.hs +21/−9
• compiler/cmm/CmmNode.hs +1/−1
• compiler/cmm/CmmOpt.hs +1/−1
• compiler/cmm/CmmParse.y +26/−23
• compiler/cmm/CmmPipeline.hs +1/−1
• compiler/cmm/CmmProcPoint.hs +1/−1
• compiler/cmm/CmmSink.hs +1/−1
• compiler/cmm/Hoopl/Block.hs +4/−8
• compiler/cmm/MkGraph.hs +2/−2
• compiler/cmm/PprC.hs +13/−7
• compiler/cmm/PprCmmExpr.hs +3/−3
• compiler/cmm/SMRep.hs +1/−1
• compiler/codeGen/CgUtils.hs +21/−21
• compiler/codeGen/CodeGen/Platform.hs +1/−1
• compiler/codeGen/StgCmmBind.hs +3/−3
• compiler/codeGen/StgCmmCon.hs +1/−1
• compiler/codeGen/StgCmmExtCode.hs +3/−4
• compiler/codeGen/StgCmmForeign.hs +126/−33
• compiler/codeGen/StgCmmMonad.hs +2/−3
• compiler/codeGen/StgCmmPrim.hs +50/−15
• compiler/coreSyn/CoreLint.hs +2/−3
• compiler/coreSyn/CorePrep.hs +17/−4
• compiler/deSugar/Check.hs +34/−118
• compiler/deSugar/Coverage.hs +2/−3
• compiler/deSugar/DsExpr.hs +9/−5
• compiler/deSugar/DsForeign.hs +1/−1
• compiler/deSugar/DsMeta.hs +16/−8
• compiler/deSugar/DsMonad.hs +2/−2
• compiler/deSugar/ExtractDocs.hs +31/−34
• compiler/deSugar/PmPpr.hs +191/−0
• compiler/deSugar/TmOracle.hs +272/−175
• compiler/ghci/ByteCodeAsm.hs +3/−5
• compiler/ghci/ByteCodeGen.hs +3/−5
• compiler/ghci/GHCi.hs +5/−5
• compiler/ghci/Linker.hs +38/−16
• compiler/hieFile/HieBin.hs +2/−1
• compiler/hsSyn/Convert.hs +15/−13
• compiler/iface/BinIface.hs +1/−1
• compiler/llvmGen/LlvmCodeGen.hs +1/−1
• compiler/llvmGen/LlvmCodeGen/Base.hs +24/−15
• compiler/llvmGen/LlvmCodeGen/CodeGen.hs +25/−10
• compiler/llvmGen/LlvmCodeGen/Data.hs +1/−1
• compiler/llvmGen/LlvmCodeGen/Regs.hs +18/−18
• compiler/llvmGen/LlvmMangler.hs +1/−1
• compiler/main/DriverPipeline.hs +16/−7
• compiler/main/DynamicLoading.hs +4/−4
• compiler/main/GHC.hs +3/−1
• compiler/main/GhcMake.hs +69/−1
• compiler/main/HscMain.hs +34/−4
• compiler/main/InteractiveEval.hs +170/−0
• compiler/main/StaticPtrTable.hs +1/−1
• compiler/main/SysTools.hs +36/−53
• compiler/main/SysTools/ExtraObj.hs +1/−1
• compiler/main/SysTools/Info.hs +2/−2
• compiler/main/SysTools/Tasks.hs +23/−17
• compiler/main/TidyPgm.hs +154/−129
• compiler/nativeGen/AsmCodeGen.hs +5/−6
• compiler/nativeGen/Dwarf.hs +1/−1
• compiler/nativeGen/Dwarf/Constants.hs +1/−1
• compiler/nativeGen/Dwarf/Types.hs +1/−1
• compiler/nativeGen/Format.hs +54/−1
• compiler/nativeGen/Instruction.hs +1/−1
• compiler/nativeGen/NCGMonad.hs +3/−5
• compiler/nativeGen/PIC.hs +1/−1
• compiler/nativeGen/PPC/CodeGen.hs +14/−1
• compiler/nativeGen/PPC/Instr.hs +1/−1
• compiler/nativeGen/PPC/Ppr.hs +7/−7
• compiler/nativeGen/PPC/Regs.hs +1/−1
• compiler/nativeGen/PprBase.hs +1/−1
• compiler/nativeGen/Reg.hs +11/−3
• compiler/nativeGen/RegAlloc/Graph/Main.hs +1/−1
• compiler/nativeGen/RegAlloc/Graph/Spill.hs +1/−1
• compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +1/−1
• compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +1/−1
• compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +1/−2
• compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +6/−1
• compiler/nativeGen/RegAlloc/Linear/Main.hs +5/−3
• compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +1/−1
• compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +1/−1
• compiler/nativeGen/RegAlloc/Linear/State.hs +4/−5
• compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +1/−1
• compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs +1/−1
• compiler/nativeGen/RegAlloc/Liveness.hs +1/−1
• compiler/nativeGen/RegClass.hs +11/−8
• compiler/nativeGen/SPARC/CodeGen.hs +8/−1
• compiler/nativeGen/SPARC/CodeGen/Base.hs +1/−1
• compiler/nativeGen/SPARC/Instr.hs +1/−1
• compiler/nativeGen/SPARC/Ppr.hs +6/−10
• compiler/nativeGen/SPARC/Regs.hs +0/−2
• compiler/nativeGen/TargetReg.hs +1/−1
• compiler/nativeGen/X86/CodeGen.hs +475/−59
• compiler/nativeGen/X86/Instr.hs +82/−1
• compiler/nativeGen/X86/Ppr.hs +145/−7
• compiler/nativeGen/X86/RegInfo.hs +4/−1
• compiler/nativeGen/X86/Regs.hs +2/−1
• compiler/prelude/PrelInfo.hs +3/−1
• compiler/rename/RnEnv.hs +4/−1
• compiler/rename/RnExpr.hs +1/−1
• compiler/rename/RnPat.hs +3/−4
• compiler/rename/RnSource.hs +47/−7
• compiler/rename/RnSplice.hs +3/−6
• compiler/rename/RnTypes.hs +5/−2
• compiler/simplCore/SimplCore.hs +1/−1
• compiler/simplCore/SimplMonad.hs +3/−4
• compiler/specialise/Specialise.hs +3/−5
• compiler/stgSyn/CoreToStg.hs +22/−11
• compiler/stgSyn/StgLint.hs +3/−4
• compiler/stgSyn/StgSyn.hs +6/−6
• compiler/typecheck/ClsInst.hs +2/−1
• compiler/typecheck/Inst.hs +4/−5
• compiler/typecheck/TcAnnotations.hs +1/−1
• compiler/typecheck/TcBinds.hs +1/−1
• compiler/typecheck/TcCanonical.hs +31/−35
• compiler/typecheck/TcErrors.hs +23/−11
• compiler/typecheck/TcExpr.hs +12/−19
• compiler/typecheck/TcFlatten.hs +2/−4
• compiler/typecheck/TcForeign.hs +1/−1
• compiler/typecheck/TcHoleErrors.hs +121/−159
• compiler/typecheck/TcHsType.hs +227/−100
• compiler/typecheck/TcInstDcls.hs +67/−22
• compiler/typecheck/TcMType.hs +40/−14
• compiler/typecheck/TcPluginM.hs +2/−2
• compiler/typecheck/TcRnDriver.hs +43/−11
• compiler/typecheck/TcRnMonad.hs +16/−18
• compiler/typecheck/TcSMonad.hs +33/−19
• compiler/typecheck/TcSigs.hs +5/−16
• compiler/typecheck/TcSimplify.hs +57/−10
• compiler/typecheck/TcTyClsDecls.hs +262/−71
• compiler/typecheck/TcTyDecls.hs +3/−6
• compiler/typecheck/TcTypeable.hs +1/−31
• compiler/typecheck/TcTypeableValidity.hs +46/−0
• compiler/typecheck/TcUnify.hs +3/−4
• compiler/utils/AsmUtils.hs +1/−1
• compiler/utils/ListT.hs +2/−3
• compiler/utils/State.hs +2/−4
• ghc-lib.cabal +31/−22
• ghc-lib/generated/ghcautoconf.h +2/−2
• ghc-lib/generated/ghcplatform.h +1/−1
• ghc-lib/generated/ghcversion.h +3/−3
• ghc-lib/stage0/compiler/build/Fingerprint.hs +48/−0
• ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs +377/−0
• ghc-lib/stage1/compiler/build/ghc_boot_platform.h +1/−1
• ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl +2/−0
• ghc-lib/stage1/compiler/build/primop-code-size.hs-incl +4/−0
• ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl +4/−0
• ghc-lib/stage1/compiler/build/primop-list.hs-incl +4/−0
• ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl +4/−0
• ghc-lib/stage1/compiler/build/primop-tag.hs-incl +1204/−1200
• ghc-lib/stage1/lib/llvm-targets +7/−3
• ghc-lib/stage1/lib/settings +3/−2
• ghc/GHCi/Leak.hs +1/−1
• ghc/GHCi/UI.hs +113/−34
• ghc/GHCi/UI/Monad.hs +41/−24
• ghc/Main.hs +10/−7
• includes/Cmm.h +11/−1
• includes/CodeGen.Platform.hs +36/−36
• includes/Rts.h +8/−0
• includes/rts/Config.h +6/−2
• includes/rts/EventLogFormat.h +1/−0
• includes/rts/storage/ClosureMacros.h +10/−6
• libraries/ghc-boot/GHC/Settings.hs +104/−0
• libraries/ghci/GHCi/InfoTable.hsc +5/−5

@@ -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

@@ -16,7 +16,7 @@ import Hoopl.Collections import Hoopl.Dataflow import Module-import Platform+import GHC.Platform import Digraph import CLabel import PprCmmDecl ()

@@ -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)

@@ -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

@@ -45,7 +45,7 @@ import qualified Stream import Hoopl.Collections -import Platform+import GHC.Platform import Maybes import DynFlags import Panic

@@ -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)

@@ -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) 

@@ -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) _).

@@ -25,7 +25,7 @@ import Util  import Outputable-import Platform+import GHC.Platform  import Data.Bits import Data.Maybe

@@ -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?

@@ -26,7 +26,7 @@ import HscTypes import Control.Monad import Outputable-import Platform+import GHC.Platform  ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline

@@ -23,7 +23,7 @@ import Maybes import Control.Monad import Outputable-import Platform+import GHC.Platform import UniqSupply import Hoopl.Block import Hoopl.Collections

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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"

@@ -49,7 +49,7 @@ import BasicTypes( ConTagZ ) import DynFlags import Outputable-import Platform+import GHC.Platform import FastString  import Data.Word

@@ -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

@@ -6,7 +6,7 @@ import GhcPrelude  import CmmExpr-import Platform+import GHC.Platform import Reg  import qualified CodeGen.Platform.ARM        as ARM

@@ -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

@@ -44,7 +44,7 @@ import Literal import PrelInfo import Outputable-import Platform+import GHC.Platform import Util import MonadUtils (mapMaybeM) 

@@ -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

@@ -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)+

@@ -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))

@@ -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

@@ -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)

@@ -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

@@ -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)+                                  -- <not a haddock> $$ ppr (delta_tm_cs _d)+                                  -- <not a haddock> $$ ppr (delta_ty_cs _d)

@@ -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)

@@ -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+    ]

@@ -49,7 +49,7 @@ import Outputable import FastString import DynFlags-import Platform+import GHC.Platform import OrdList import Pair import Util

@@ -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)

@@ -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) }) 

@@ -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

@@ -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

@@ -1,23 +1,27 @@ {- Author: George Karachalias <george.karachalias@cs.kuleuven.be>--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`. -}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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:

@@ -42,7 +42,7 @@ import Unique import Outputable import NameCache-import Platform+import GHC.Platform import FastString import Constants import Util

@@ -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" 

@@ -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)

@@ -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

@@ -18,7 +18,7 @@ import CLabel import Cmm import DynFlags-import Platform+import GHC.Platform  import FastString import Outputable

@@ -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!"

@@ -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 ) 

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -135,7 +135,7 @@ import Module import Name import Outputable-import Platform+import GHC.Platform import PrelNames import TcEnv (lookupGlobal) import Type

@@ -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          }  

@@ -17,7 +17,7 @@ import ErrUtils import DynFlags import Packages-import Platform+import GHC.Platform import Outputable import SrcLoc           ( noSrcSpan ) import Module

@@ -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

@@ -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 ()

@@ -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)

@@ -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

@@ -12,7 +12,7 @@ import DynFlags import Module import Outputable-import Platform+import GHC.Platform import Unique import UniqSupply 

@@ -7,7 +7,7 @@  import AsmUtils import FastString-import Platform+import GHC.Platform import Outputable  import Reg

@@ -30,7 +30,7 @@ import Encoding import FastString import Outputable-import Platform+import GHC.Platform import Unique import Reg import SrcLoc

@@ -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

@@ -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.

@@ -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

@@ -54,7 +54,7 @@  import qualified X86.Instr      as X86 -import Platform+import GHC.Platform import Instruction import Reg import NCGMonad

@@ -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

@@ -43,7 +43,7 @@ import FastString import CLabel import Outputable-import Platform+import GHC.Platform import UniqFM (listToUFM, lookupUFM) import UniqSupply 

@@ -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',

@@ -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 )

@@ -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 )

@@ -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   

@@ -21,7 +21,7 @@ import Bag import DynFlags import Outputable-import Platform+import GHC.Platform import UniqFM import UniqSet import UniqSupply

@@ -23,7 +23,7 @@ import UniqSet import UniqSupply import Outputable-import Platform+import GHC.Platform  import Data.List import Data.Maybe

@@ -41,7 +41,7 @@ import Unique import State import Outputable-import Platform+import GHC.Platform import Hoopl.Collections  import Data.List

@@ -28,7 +28,7 @@ import UniqSet import Digraph          (flattenSCCs) import Outputable-import Platform+import GHC.Platform import State import CFG 

@@ -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-   

@@ -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

@@ -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 

@@ -9,7 +9,7 @@ import Reg  import Outputable-import Platform+import GHC.Platform  import Data.Word import Data.Bits

@@ -11,7 +11,7 @@  import CodeGen.Platform import Outputable-import Platform+import GHC.Platform  import Data.Word import Data.Bits

@@ -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

@@ -9,7 +9,7 @@ import RegClass import Reg import Panic-import Platform+import GHC.Platform  import Data.Word import Data.Bits

@@ -9,7 +9,7 @@ import RegClass import Reg import Panic-import Platform+import GHC.Platform  import Data.Word import Data.Bits

@@ -51,7 +51,7 @@ import DynFlags import MonadUtils import Outputable-import Platform+import GHC.Platform import UniqSet import UniqFM import UniqSupply

@@ -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"

@@ -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

@@ -26,7 +26,7 @@ import DynFlags import Cmm import PprCmmExpr ()-import Platform+import GHC.Platform  import Outputable import OrdList

@@ -46,7 +46,7 @@ import Cmm import FastString import Outputable-import Platform+import GHC.Platform   -- | Register or immediate

@@ -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")   

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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+    ]

@@ -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

@@ -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  

@@ -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

@@ -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

@@ -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 

@@ -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)

@@ -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)

@@ -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

@@ -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" 

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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]  {- ************************************************************************

@@ -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 }

@@ -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)+  {- ************************************************************************

@@ -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

@@ -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)

@@ -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

@@ -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")

@@ -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)

@@ -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)

@@ -57,7 +57,7 @@ import PrelNames import DynFlags import Outputable-import Platform+import GHC.Platform import SrcLoc import Bag import Hooks