ghc-lib 0.20190402 → 0.20190423

raw patch · 57 files changed

+1130/−1349 lines, 57 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 +137/−1
• compiler/cmm/CmmCallConv.hs +1/−1
• compiler/cmm/CmmExpr.hs +16/−1
• compiler/codeGen/StgCmmBind.hs +3/−1
• compiler/codeGen/StgCmmPrim.hs +70/−40
• compiler/coreSyn/CoreLint.hs +6/−3
• compiler/deSugar/Check.hs +122/−81
• compiler/deSugar/TmOracle.hs +3/−1
• compiler/ghci/ByteCodeLink.hs +2/−2
• compiler/llvmGen/Llvm/Types.hs +1/−0
• compiler/llvmGen/LlvmCodeGen/Base.hs +28/−5
• compiler/llvmGen/LlvmCodeGen/Data.hs +31/−3
• compiler/llvmGen/LlvmCodeGen/Ppr.hs +1/−1
• compiler/main/DriverPipeline.hs +3/−12
• compiler/main/Finder.hs +13/−2
• compiler/main/HscMain.hs +2/−0
• compiler/main/SysTools.hs +2/−7
• compiler/main/SysTools/ExtraObj.hs +1/−1
• compiler/main/SysTools/Tasks.hs +21/−4
• compiler/nativeGen/AsmCodeGen.hs +2/−20
• compiler/nativeGen/Format.hs +2/−4
• compiler/nativeGen/NCGMonad.hs +0/−1
• compiler/nativeGen/PPC/CodeGen.hs +2/−4
• compiler/nativeGen/PPC/Ppr.hs +13/−5
• compiler/nativeGen/PPC/Regs.hs +1/−1
• compiler/nativeGen/Reg.hs +10/−10
• compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +12/−26
• compiler/nativeGen/RegClass.hs +0/−3
• compiler/nativeGen/SPARC/Instr.hs +0/−3
• compiler/nativeGen/SPARC/Ppr.hs +14/−6
• compiler/nativeGen/SPARC/Regs.hs +0/−2
• compiler/nativeGen/X86/CodeGen.hs +172/−231
• compiler/nativeGen/X86/Instr.hs +18/−152
• compiler/nativeGen/X86/Ppr.hs +43/−398
• compiler/nativeGen/X86/RegInfo.hs +9/−16
• compiler/nativeGen/X86/Regs.hs +45/−58
• compiler/prelude/THNames.hs +7/−4
• compiler/simplStg/StgCse.hs +2/−2
• compiler/specialise/Specialise.hs +23/−16
• compiler/stgSyn/StgSyn.hs +18/−5
• compiler/typecheck/Inst.hs +14/−8
• compiler/typecheck/TcCanonical.hs +1/−1
• compiler/typecheck/TcDeriv.hs +2/−0
• compiler/typecheck/TcDerivUtils.hs +6/−4
• compiler/typecheck/TcExpr.hs +8/−6
• compiler/typecheck/TcGenDeriv.hs +17/−62
• compiler/typecheck/TcMType.hs +1/−1
• compiler/typecheck/TcSigs.hs +1/−1
• compiler/typecheck/TcSplice.hs +6/−3
• compiler/typecheck/TcTyClsDecls.hs +60/−24
• ghc-lib.cabal +3/−3
• ghc-lib/generated/ghcversion.h +2/−1
• ghc-lib/stage1/lib/settings +34/−35
• ghc/GHCi/UI.hs +57/−13
• ghc/GHCi/UI/Info.hs +3/−0
• ghc/GHCi/UI/Monad.hs +11/−0
• includes/CodeGen.Platform.hs +48/−54

@@ -98,7 +98,7 @@         needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,         isMathFun,         isCFunctionLabel, isGcPtrLabel, labelDynamic,-        isLocalCLabel,+        isLocalCLabel, mayRedirectTo,          -- * Conversions         toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,@@ -1432,3 +1432,139 @@           SymbolPtr       -> text ".LC_" <> ppr lbl           GotSymbolPtr    -> ppr lbl <> text "@got"           GotSymbolOffset -> ppr lbl <> text "@gotoff"++-- Figure out whether `symbol` may serve as an alias+-- to `target` within one compilation unit.+--+-- This is true if any of these holds:+-- * `target` is a module-internal haskell name.+-- * `target` is an exported name, but comes from the same+--   module as `symbol`+--+-- These are sufficient conditions for establishing e.g. a+-- GNU assembly alias ('.equiv' directive). Sadly, there is+-- no such thing as an alias to an imported symbol (conf.+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)+-- See note [emit-time elimination of static indirections].+--+-- Precondition is that both labels represent the+-- same semantic value.++mayRedirectTo :: CLabel -> CLabel -> Bool+mayRedirectTo symbol target+ | Just nam <- haskellName+ , staticClosureLabel+ , isExternalName nam+ , Just mod <- nameModule_maybe nam+ , Just anam <- hasHaskellName symbol+ , Just amod <- nameModule_maybe anam+ = amod == mod++ | Just nam <- haskellName+ , staticClosureLabel+ , isInternalName nam+ = True++ | otherwise = False+   where staticClosureLabel = isStaticClosureLabel target+         haskellName = hasHaskellName target+++{-+Note [emit-time elimination of static indirections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in #15155, certain static values are repesentationally+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).++             newtype A = A Int+             {-# NOINLINE a #-}+             a = A 42++a1_rYB :: Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []]+a1_rYB = GHC.Types.I# 42#++a [InlPrag=NOINLINE] :: A+[GblId, Unf=OtherCon []]+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)++Formerly we created static indirections for these (IND_STATIC), which+consist of a statically allocated forwarding closure that contains+the (possibly tagged) indirectee. (See CMM/assembly below.)+This approach is suboptimal for two reasons:+  (a) they occupy extra space,+  (b) they need to be entered in order to obtain the indirectee,+      thus they cannot be tagged.++Fortunately there is a common case where static indirections can be+eliminated while emitting assembly (native or LLVM), viz. when the+indirectee is in the same module (object file) as the symbol that+points to it. In this case an assembly-level identification can+be created ('.equiv' directive), and as such the same object will+be assigned two names in the symbol table. Any of the identified+symbols can be referenced by a tagged pointer.++Currently the 'mayRedirectTo' predicate will+give a clue whether a label can be equated with another, already+emitted, label (which can in turn be an alias). The general mechanics+is that we identify data (IND_STATIC closures) that are amenable+to aliasing while pretty-printing of assembly output, and emit the+'.equiv' directive instead of static data in such a case.++Here is a sketch how the output is massaged:++                     Consider+newtype A = A Int+{-# NOINLINE a #-}+a = A 42                                -- I# 42# is the indirectee+                                        -- 'a' is exported++                 results in STG++a1_rXq :: GHC.Types.Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =+    CCS_DONT_CARE GHC.Types.I#! [42#];++T15155.a [InlPrag=NOINLINE] :: T15155.A+[GblId, Unf=OtherCon []] =+    CAF_ccs  \ u  []  a1_rXq;++                 and CMM++[section ""data" . a1_rXq_closure" {+     a1_rXq_closure:+         const GHC.Types.I#_con_info;+         const 42;+ }]++[section ""data" . T15155.a_closure" {+     T15155.a_closure:+         const stg_IND_STATIC_info;+         const a1_rXq_closure+1;+         const 0;+         const 0;+ }]++The emitted assembly is++#### INDIRECTEE+a1_rXq_closure:                         -- module local haskell value+        .quad   GHC.Types.I#_con_info   -- an Int+        .quad   42++#### BEFORE+.globl T15155.a_closure                 -- exported newtype wrapped value+T15155.a_closure:+        .quad   stg_IND_STATIC_info     -- the closure info+        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)+        .quad   0+        .quad   0++#### AFTER+.globl T15155.a_closure                 -- exported newtype wrapped value+.equiv a1_rXq_closure,T15155.a_closure  -- both are shared++The transformation is performed because+     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1+returns True.+-}

@@ -81,7 +81,6 @@                             | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))                         (W64, (vs, fs, d:ds, ls, ss))                             | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))-                        (W80, _) -> panic "F80 unsupported register type"                         _ -> (assts, (r:rs))               int = case (w, regs) of                       (W128, _) -> panic "W128 unsupported register type"@@ -100,6 +99,7 @@ passFloatArgsInXmm :: DynFlags -> Bool passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of                               ArchX86_64 -> True+                              ArchX86    -> False                               _          -> False  -- We used to spill vector registers to the stack since the LLVM backend didn't

@@ -5,7 +5,7 @@ {-# LANGUAGE UndecidableInstances #-}  module CmmExpr-    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr+    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr     , CmmReg(..), cmmRegType, cmmRegWidth     , CmmLit(..), cmmLitType     , LocalReg(..), localRegType@@ -43,6 +43,8 @@ import Data.Set (Set) import qualified Data.Set as Set +import BasicTypes (Alignment, mkAlignment, alignmentOf)+ ----------------------------------------------------------------------------- --              CmmExpr -- An expression.  Expressions have no side effects.@@ -239,6 +241,13 @@ cmmExprWidth :: DynFlags -> CmmExpr -> Width cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) +-- | Returns an alignment in bytes of a CmmExpr when it's a statically+-- known integer constant, otherwise returns an alignment of 1 byte.+-- The caller is responsible for using with a sensible CmmExpr+-- argument.+cmmExprAlignment :: CmmExpr -> Alignment+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)+cmmExprAlignment _                          = mkAlignment 1 -------- --- Negation for conditional branches @@ -474,6 +483,9 @@    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@@ -584,6 +596,9 @@ 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)

@@ -78,7 +78,9 @@   -- closure pointing directly to the indirectee.  This is exactly   -- what the CAF will eventually evaluate to anyway, we're just   -- shortcutting the whole process, and generating a lot less code-  -- (#7308)+  -- (#7308). Eventually the IND_STATIC closure will be eliminated+  -- by assembly '.equiv' directives, where possible (#15155).+  -- See note [emit-time elimination of static indirections] in CLabel.   --   -- Note: we omit the optimisation when this binding is part of a   -- recursive group, because the optimisation would inhibit the black

@@ -1727,8 +1727,38 @@ vecElemProjectCast _      WordVec  W64 =  Nothing vecElemProjectCast _      _        _   =  Nothing ++-- NOTE [SIMD Design for the future] -- Check to make sure that we can generate code for the specified vector type -- given the current set of dynamic flags.+-- Currently these checks are specific to x86 and x86_64 architecture.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurments is the only only way to validate that.+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension+--    includes  support for a sort of run time CPU dependent vectorization parameter,+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...+--    element chunk! Time will tell if that direction sees wide adoption,+--    but it is from that context that unifying our handling of simd and scalars+--    may benefit. It is not likely to benefit current architectures, though+--    it may very well be a design perspective that helps guide improving the NCG.++ checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility dflags vcat l w = do     when (hscTarget dflags /= HscLlvm) $ do@@ -2005,8 +2035,8 @@   where     -- Copy data (we assume the arrays aren't overlapping since     -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        emitMemcpyCall dst_p src_p bytes 1+    copy _src _dst dst_p src_p bytes align =+        emitMemcpyCall dst_p src_p bytes align  -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the@@ -2020,22 +2050,26 @@     -- The only time the memory might overlap is when the two arrays     -- we were provided are the same array!     -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do+    copy src dst dst_p src_p bytes align = do         dflags <- getDynFlags         (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p bytes 1)-            (getCode $ emitMemcpyCall  dst_p src_p bytes 1)+            (getCode $ emitMemmoveCall dst_p src_p bytes align)+            (getCode $ emitMemcpyCall  dst_p src_p bytes align)         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall  emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                      -> FCode ())+                      -> Alignment -> FCode ())                   -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr                   -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do     dflags <- getDynFlags+    let byteArrayAlignment = wordAlignment dflags+        srcOffAlignment = cmmExprAlignment src_off+        dstOffAlignment = cmmExprAlignment dst_off+        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]     dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off     src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off-    copy src dst dst_p src_p n+    copy src dst dst_p src_p n align  -- | Takes a source 'ByteArray#', an offset in the source array, a -- destination 'Addr#', and the number of bytes to copy.  Copies the given@@ -2045,7 +2079,7 @@     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     dflags <- getDynFlags     src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off-    emitMemcpyCall dst_p src_p bytes 1+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)  -- | Takes a source 'MutableByteArray#', an offset in the source array, a -- destination 'Addr#', and the number of bytes to copy.  Copies the given@@ -2062,7 +2096,7 @@     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     dflags <- getDynFlags     dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off-    emitMemcpyCall dst_p src_p bytes 1+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)   -- ----------------------------------------------------------------------------@@ -2073,11 +2107,16 @@ -- character. doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr                  -> FCode ()-doSetByteArrayOp ba off len c-    = do dflags <- getDynFlags-         p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off-         emitMemsetCall p c len 1+doSetByteArrayOp ba off len c = do+    dflags <- getDynFlags +    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap+        offsetAlignment = cmmExprAlignment off+        align = min byteArrayAlignment offsetAlignment++    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off+    emitMemsetCall p c len align+ -- ---------------------------------------------------------------------------- -- Allocating arrays @@ -2104,18 +2143,9 @@     emit $ mkAssign arr base      -- Initialise all elements of the array-    p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)-    for <- newBlockId-    emitLabel for-    let loopBody =-            [ mkStore (CmmReg (CmmLocal p)) init-            , mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1)-            , mkBranch for ]-    emit =<< mkCmmIfThen-        (cmmULtWord dflags (CmmReg (CmmLocal p))-         (cmmOffsetW dflags (CmmReg arr)-          (hdrSizeW dflags rep + n)))-        (catAGraphs loopBody)+    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)+        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]+    emit (catAGraphs initialization)      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -2149,7 +2179,7 @@     copy _src _dst dst_p src_p bytes =         do dflags <- getDynFlags            emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wORD_SIZE dflags)+               (wordAlignment dflags)   -- | Takes a source 'MutableArray#', an offset in the source array, a@@ -2167,9 +2197,9 @@         dflags <- getDynFlags         (moveCall, cpyCall) <- forkAltPair             (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))+             (wordAlignment dflags))             (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))+             (wordAlignment dflags))         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall  emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff@@ -2216,7 +2246,7 @@     copy _src _dst dst_p src_p bytes =         do dflags <- getDynFlags            emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wORD_SIZE dflags)+               (wordAlignment dflags)   doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff@@ -2230,9 +2260,9 @@         dflags <- getDynFlags         (moveCall, cpyCall) <- forkAltPair             (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))+             (wordAlignment dflags))             (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))+             (wordAlignment dflags))         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall  emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff@@ -2297,7 +2327,7 @@               (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)      emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wORD_SIZE dflags)+        (wordAlignment dflags)      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -2334,7 +2364,7 @@               (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)      emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wORD_SIZE dflags)+        (wordAlignment dflags)      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -2353,7 +2383,7 @@     emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)         (mkIntExpr dflags 1)         (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))-        1 -- no alignment (1 byte)+        (mkAlignment 1) -- no alignment (1 byte)  -- Convert an element index to a card index cardCmm :: DynFlags -> CmmExpr -> CmmExpr@@ -2462,28 +2492,28 @@ -- Helpers for emitting function calls  -- | Emit a call to @memcpy@.-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () emitMemcpyCall dst src n align = do     emitPrimCall         [ {-no results-} ]-        (MO_Memcpy align)+        (MO_Memcpy (alignmentBytes align))         [ dst, src, n ]  -- | Emit a call to @memmove@.-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () emitMemmoveCall dst src n align = do     emitPrimCall         [ {- no results -} ]-        (MO_Memmove align)+        (MO_Memmove (alignmentBytes align))         [ dst, src, n ]  -- | Emit a call to @memset@.  The second argument must fit inside an -- unsigned char.-emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () emitMemsetCall dst c n align = do     emitPrimCall         [ {- no results -} ]-        (MO_Memset align)+        (MO_Memset (alignmentBytes align))         [ dst, c, n ]  emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()

@@ -2080,7 +2080,7 @@ newtype LintM a =    LintM { unLintM ::             LintEnv ->-            WarnsAndErrs ->           -- Error and warning messages so far+            WarnsAndErrs ->           -- Warning and error messages so far             (Maybe a, WarnsAndErrs) } -- Result and messages (if any)  type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)@@ -2189,10 +2189,13 @@   | InCo   Coercion     -- Inside a coercion  initL :: DynFlags -> LintFlags -> InScopeSet-       -> LintM a -> WarnsAndErrs    -- Errors and warnings+       -> LintM a -> WarnsAndErrs    -- Warnings and errors initL dflags flags in_scope m   = case unLintM m env (emptyBag, emptyBag) of-      (_, errs) -> errs+      (Just _, errs) -> errs+      (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs+                             | otherwise -> pprPanic ("Bug in Lint: a failure occurred " +++                                                      "without reporting an error message") empty   where     env = LE { le_flags = flags              , le_subst = mkEmptyTCvSubst in_scope

@@ -4,9 +4,13 @@ Pattern Matching Coverage Checking. -} -{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns  #-}+{-# LANGUAGE CPP            #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TupleSections  #-}+{-# LANGUAGE ViewPatterns   #-}+{-# LANGUAGE MultiWayIf     #-}  module Check (         -- Checking and printing@@ -55,7 +59,7 @@  import Data.List     (find) import Data.Maybe    (catMaybes, isJust, fromMaybe)-import Control.Monad (forM, when, forM_, zipWithM)+import Control.Monad (forM, when, forM_, zipWithM, filterM) import Coercion import TcEvidence import TcSimplify    (tcNormalise)@@ -153,7 +157,9 @@   PmNLit :: { pm_lit_id   :: Id             , pm_lit_not  :: [PmLit] } -> PmPat 'VA   PmGrd  :: { pm_grd_pv   :: PatVec-            , pm_grd_expr :: PmExpr  } -> PmPat 'PAT+            , pm_grd_expr :: PmExpr } -> PmPat 'PAT+  -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.+  PmFake :: PmPat 'PAT  instance Outputable (PmPat a) where   ppr = pprPmPatDebug@@ -289,6 +295,14 @@     , pmresultUncovered    :: UncoveredCandidates     , pmresultInaccessible :: [Located [LPat GhcTc]] } +instance Outputable PmResult where+  ppr pmr = hang (text "PmResult") 2 $ vcat+    [ text "pmresultProvenance" <+> ppr (pmresultProvenance pmr)+    , text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)+    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)+    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)+    ]+ -- | Either a list of patterns that are not covered, or their type, in case we -- have no patterns at hand. Not having patterns at hand can arise when -- handling EmptyCase expressions, in two cases:@@ -303,6 +317,10 @@ data UncoveredCandidates = UncoveredPatterns Uncovered                          | TypeOfUncovered Type +instance Outputable UncoveredCandidates where+  ppr (UncoveredPatterns uc) = text "UnPat" <+> ppr uc+  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr ty+ -- | The empty pattern check result emptyPmResult :: PmResult emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []@@ -912,24 +930,11 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon) {-# INLINE truePattern #-} --- | A fake guard pattern (True <- _) used to represent cases we cannot handle-fake_pat :: Pattern-fake_pat = PmGrd { pm_grd_pv   = [truePattern]-                 , pm_grd_expr = PmExprOther (EWildPat noExt) }-{-# INLINE fake_pat #-}---- | Check whether a guard pattern is generated by the checker (unhandled)-isFakeGuard :: [Pattern] -> PmExpr -> Bool-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))-  | c == trueDataCon = True-  | otherwise        = False-isFakeGuard _pats _e = False- -- | Generate a `canFail` pattern vector of a specific type mkCanFailPmPat :: Type -> DsM PatVec mkCanFailPmPat ty = do   var <- mkPmVar ty-  return [var, fake_pat]+  return [var, PmFake]  vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern -- ADT constructor pattern => no existentials, no local constraints@@ -987,7 +992,7 @@     | otherwise -> do         ps      <- translatePat fam_insts p         (xp,xe) <- mkPmId2Forms ty-        let g = mkGuard ps (mkHsWrap wrapper (unLoc xe))+        g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))         return [xp,g]    -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)@@ -997,10 +1002,11 @@   ViewPat arg_ty lexpr lpat -> do     ps <- translatePat fam_insts (unLoc lpat)     -- See Note [Guards and Approximation]-    case all cantFailPattern ps of+    res <- allM cantFailPattern ps+    case res of       True  -> do         (xp,xe) <- mkPmId2Forms arg_ty-        let g = mkGuard ps (HsApp noExt lexpr xe)+        g <- mkGuard ps (HsApp noExt lexpr xe)         return [xp,g]       False -> mkCanFailPmPat arg_ty @@ -1255,41 +1261,38 @@ translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec translateGuards fam_insts guards = do   all_guards <- concat <$> mapM (translateGuard fam_insts) guards-  return (replace_unhandled all_guards)-  -- It should have been (return all_guards) but it is too expressive.+  let+    shouldKeep :: Pattern -> DsM Bool+    shouldKeep p+      | PmVar {} <- p = pure True+      | PmCon {} <- p = (&&)+                          <$> singleMatchConstructor (pm_con_con p) (pm_con_arg_tys p)+                          <*> allM shouldKeep (pm_con_args p)+    shouldKeep (PmGrd pv e)+      | isNotPmExprOther e = pure True  -- expensive but we want it+      | otherwise          = allM shouldKeep pv+    shouldKeep _other_pat  = pure False -- let the rest..++  all_handled <- allM shouldKeep all_guards+  -- It should have been @pure all_guards@ but it is too expressive.   -- Since the term oracle does not handle all constraints we generate,   -- we (hackily) replace all constraints the oracle cannot handle with a-  -- single one (we need to know if there is a possibility of falure).+  -- single one (we need to know if there is a possibility of failure).   -- See Note [Guards and Approximation] for all guard-related approximations   -- we implement.-  where-    replace_unhandled :: PatVec -> PatVec-    replace_unhandled gv-      | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]-      | otherwise        = gv--    any_unhandled :: PatVec -> Bool-    any_unhandled gv = any (not . shouldKeep) gv--    shouldKeep :: Pattern -> Bool-    shouldKeep p-      | PmVar {} <- p      = True-      | PmCon {} <- p      = singleConstructor (pm_con_con p)-                             && all shouldKeep (pm_con_args p)-    shouldKeep (PmGrd pv e)-      | all shouldKeep pv  = True-      | isNotPmExprOther e = True  -- expensive but we want it-    shouldKeep _other_pat  = False -- let the rest..+  if all_handled+    then pure all_guards+    else do+      kept <- filterM shouldKeep all_guards+      pure (PmFake : kept)  -- | Check whether a pattern can fail to match-cantFailPattern :: Pattern -> Bool-cantFailPattern p-  | PmVar {} <- p = True-  | PmCon {} <- p = singleConstructor (pm_con_con p)-                    && all cantFailPattern (pm_con_args p)-cantFailPattern (PmGrd pv _e)-                  = all cantFailPattern pv-cantFailPattern _ = False+cantFailPattern :: Pattern -> DsM Bool+cantFailPattern PmVar {}      = pure True+cantFailPattern PmCon { pm_con_con = c, pm_con_arg_tys = tys, pm_con_args = ps}+  = (&&) <$> singleMatchConstructor c tys <*> allM cantFailPattern ps+cantFailPattern (PmGrd pv _e) = allM cantFailPattern pv+cantFailPattern _             = pure False  -- | Translate a guard statement to Pattern translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec@@ -1312,7 +1315,8 @@ translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec translateBind fam_insts (dL->L _ p) e = do   ps <- translatePat fam_insts p-  return [mkGuard ps (unLoc e)]+  g <- mkGuard ps (unLoc e)+  return [g]  -- | Translate a boolean guard translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec@@ -1321,7 +1325,7 @@     -- The formal thing to do would be to generate (True <- True)     -- but it is trivial to solve so instead we give back an empty     -- PatVec for efficiency-  | otherwise = return [mkGuard [truePattern] (unLoc e)]+  | otherwise = (:[]) <$> mkGuard [truePattern] (unLoc e)  {- Note [Guards and Approximation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1362,7 +1366,7 @@           expressivity in our warnings.       Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*-     @fake_pat@: @True <- _@. That is, we record that there is a possibility+     @PmFake@: @True <- _@. That is, we record that there is a possibility      of failure but we minimize it to a True/False. This generates a single      warning and much smaller uncovered sets. @@ -1406,7 +1410,7 @@  Additionally, top-level guard translation (performed by @translateGuards@) replaces guards that cannot be reasoned about (like the ones we described in-1-4) with a single @fake_pat@ to record the possibility of failure to match.+1-4) with a single @PmFake@ to record the possibility of failure to match.  Note [Translate CoPats] ~~~~~~~~~~~~~~~~~~~~~~~@@ -1442,6 +1446,7 @@ pmPatType (PmGrd  { pm_grd_pv  = pv })   = ASSERT(patVecArity pv == 1) (pmPatType p)   where Just p = find ((==1) . patternArity) pv+pmPatType PmFake = pmPatType truePattern  -- | Information about a conlike that is relevant to coverage checking. -- It is called an \"inhabitation candidate\" since it is a value which may@@ -1658,13 +1663,14 @@ -- * More smart constructors and fresh variable generation  -- | Create a guard pattern-mkGuard :: PatVec -> HsExpr GhcTc -> Pattern-mkGuard pv e-  | all cantFailPattern pv = PmGrd pv expr-  | PmExprOther {} <- expr = fake_pat-  | otherwise              = PmGrd pv expr-  where-    expr = hsExprToPmExpr e+mkGuard :: PatVec -> HsExpr GhcTc -> DsM Pattern+mkGuard pv e = do+  res <- allM cantFailPattern pv+  let expr = hsExprToPmExpr e+  tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])+  if | res                    -> pure (PmGrd pv expr)+     | PmExprOther {} <- expr -> pure PmFake+     | otherwise              -> pure (PmGrd pv expr)  -- | Create a term equality of the form: `(False ~ (x ~ lit))` mkNegEq :: Id -> PmLit -> ComplexEq@@ -1737,16 +1743,40 @@            , pm_con_tvs  = tvs, pm_con_dicts = dicts            , pm_con_args = coercePatVec args }] coercePmPat (PmGrd {}) = [] -- drop the guards+coercePmPat PmFake     = [] -- drop the guards --- | Check whether a data constructor is the only way to construct--- a data type.-singleConstructor :: ConLike -> Bool-singleConstructor (RealDataCon dc) =-  case tyConDataCons (dataConTyCon dc) of-    [_] -> True-    _   -> False-singleConstructor _ = False+-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether+-- it is the only possible match in the given context. See also+-- 'allCompleteMatches' and Note [Single match constructors].+singleMatchConstructor :: ConLike -> [Type] -> DsM Bool+singleMatchConstructor cl tys =+  any (isSingleton . snd) <$> allCompleteMatches cl tys +{-+Note [Single match constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When translating pattern guards for consumption by the checker, we desugar+every pattern guard that might fail ('cantFailPattern') to 'PmFake'+(True <- _). Which patterns can't fail? Exactly those that only match on+'singleMatchConstructor's.++Here are a few examples:+  * @f a | (a, b) <- foo a = 42@: Product constructors are generally+    single match. This extends to single constructors of GADTs like 'Refl'.+  * If @f | Id <- id () = 42@, where @pattern Id = ()@ and 'Id' is part of a+    singleton `COMPLETE` set, then 'Id' has the single match property.++In effect, we can just enumerate 'allCompleteMatches' and check if the conlike+occurs as a singleton set.+There's the chance that 'Id' is part of multiple `COMPLETE` sets. That's+irrelevant; If the user specified a singleton set, it is single-match.++Note that this doesn't really take into account incoming type constraints;+It might be obvious from type context that a particular GADT constructor has+the single-match property. We currently don't (can't) check this in the+translation step. See #15753 for why this yields surprising results.+-}+ -- | For a given conlike, finds all the sets of patterns which could -- be relevant to that conlike by consulting the result type. --@@ -1984,13 +2014,15 @@   | otherwise   = pmcheckGuardsI guards vva  -- Guard-pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)-    -- short-circuit if the guard pattern is useless.-    -- we just have two possible outcomes: fail here or match and recurse-    -- none of the two contains any useful information about the failure-    -- though. So just have these two cases but do not do all the boilerplate-  | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva-  | otherwise = do+pmcheck (PmFake : ps) guards vva =+  -- short-circuit if the guard pattern is useless.+  -- we just have two possible outcomes: fail here or match and recurse+  -- none of the two contains any useful information about the failure+  -- though. So just have these two cases but do not do all the boilerplate+  forces . mkCons vva <$> pmcheckI ps guards vva+pmcheck (p : ps) guards (ValVec vas delta)+  | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p+  = do       y <- liftD $ mkPmId (pmPatType p)       let tm_state = extendSubst y e (delta_tm_cs delta)           delta'   = delta { delta_tm_cs = tm_state }@@ -2118,15 +2150,22 @@ -- no information is lost  -- LitCon-pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)+pmcheckHd p@PmLit{} ps guards va@PmCon{} (ValVec vva delta)   = do y <- liftD $ mkPmId (pmPatType va)-       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)+       -- Analogous to the ConVar case, we have to case split the value+       -- abstraction on possible literals. We do so by introducing a fresh+       -- variable that is equated to the constructor. LitVar will then take+       -- care of the case split by resorting to NLit.+       let tm_state = extendSubst y (vaToPmExpr va) (delta_tm_cs delta)            delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')  -- ConLit-pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)+pmcheckHd p@PmCon{} ps guards (PmLit l) (ValVec vva delta)   = do y <- liftD $ mkPmId (pmPatType p)+       -- This desugars to the ConVar case by introducing a fresh variable that+       -- is equated to the literal via a constraint. ConVar will then properly+       -- case split on all possible constructors.        let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)            delta'   = delta { delta_tm_cs = tm_state }        pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')@@ -2136,6 +2175,7 @@   = pmcheckHdI p ps guards (PmVar x) vva  -- Impossible: handled by pmcheck+pmcheckHd PmFake     _ _ _ _ = panic "pmcheckHd: Fake" pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"  {-@@ -2696,6 +2736,7 @@ pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)                                            <+> ppr ge+pprPmPatDebug PmFake = text "PmFake"  pprPatVec :: PatVec -> SDoc pprPatVec ps = hang (text "Pattern:") 2

@@ -33,6 +33,7 @@ import TcHsSyn import MonadUtils import Util+import Outputable  import NameEnv @@ -134,7 +135,8 @@    (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env)) -  _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS+  _ -> WARN( True, text "solveComplexEq: Catch all" <+> ppr eq )+       Just (standby, (True, env)) -- I HATE CATCH-ALLS  -- | Extend the substitution and solve the (possibly updated) constraints. extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState

@@ -154,8 +154,8 @@                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"                 , "flags, or simply by naming the relevant files on the GHCi command line."                 , "Alternatively, this link failure might indicate a bug in GHCi."-                , "If you suspect the latter, please send a bug report to:"-                , "  glasgow-haskell-bugs@haskell.org"+                , "If you suspect the latter, please report this as a GHC bug:"+                , "  https://www.haskell.org/ghc/reportabug"                 ])  

@@ -185,6 +185,7 @@ pprSpecialStatic (LMBitc v t) =     ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t         <> char ')'+pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v pprSpecialStatic stat = ppr stat  

@@ -31,7 +31,7 @@         strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,         getGlobalPtr, generateExternDecls, -        aliasify,+        aliasify, llvmDefLabel     ) where  #include "HsVersions.h"@@ -57,6 +57,7 @@ import ErrUtils import qualified Stream +import Data.Maybe (fromJust) import Control.Monad (ap)  -- ----------------------------------------------------------------------------@@ -97,7 +98,6 @@ widthToLlvmFloat :: Width -> LlvmType widthToLlvmFloat W32  = LMFloat widthToLlvmFloat W64  = LMDouble-widthToLlvmFloat W80  = LMFloat80 widthToLlvmFloat W128 = LMFloat128 widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w @@ -377,7 +377,7 @@     mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]   where     mk n ret args = do-      let n' = fsLit n `appendFS` fsLit "$def"+      let n' = llvmDefLabel $ fsLit n           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret                                  FixedArgs (tysToParams args) Nothing       renderLlvm $ ppLlvmFunctionDecl decl@@ -437,12 +437,17 @@   let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing   case m_ty of     -- Directly reference if we have seen it already-    Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global+    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global     -- Otherwise use a forward alias of it     Nothing -> do       saveAlias llvmLbl       return $ mkGlbVar llvmLbl i8 Alias +-- | Derive the definition label. It has an identified+-- structure type.+llvmDefLabel :: LMString -> LMString+llvmDefLabel = (`appendFS` fsLit "$def")+ -- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. -- -- Must be called at a point where we are sure that no new global definitions@@ -473,10 +478,28 @@ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]+-- See note [emit-time elimination of static indirections] in CLabel.+-- Here we obtain the indirectee's precise type and introduce+-- fresh aliases to both the precise typed label (lbl$def) and the i8*+-- typed (regular) label of it with the matching new names.+aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)+                   (Just orig)) = do+    let defLbl = llvmDefLabel lbl+        LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig+        defOrigLbl = llvmDefLabel origLbl+        orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)+    origType <- funLookup origLbl+    let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl+                                           (pLift $ fromJust origType) oLnk+                                           Nothing Nothing Alias))+                         (pLift ty)+    pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)+         , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')+         ] aliasify (LMGlobal var val) = do     let LMGlobalVar lbl ty link sect align const = var -        defLbl = lbl `appendFS` fsLit "$def"+        defLbl = llvmDefLabel lbl         defVar = LMGlobalVar defLbl ty Internal sect align const          defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const

@@ -32,12 +32,41 @@ structStr :: LMString structStr = fsLit "_struct" +-- | The LLVM visibility of the label+linkage :: CLabel -> LlvmLinkageType+linkage lbl = if externallyVisibleCLabel lbl+              then ExternallyVisible else Internal+ -- ---------------------------------------------------------------------------- -- * Top level --  -- | Pass a CmmStatic section to an equivalent Llvm code. genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData+-- See note [emit-time elimination of static indirections] in CLabel.+genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind' = do+    label <- strCLabel_llvm alias+    label' <- strCLabel_llvm ind'+    let link     = linkage alias+        link'    = linkage ind'+        -- the LLVM type we give the alias is an empty struct type+        -- but it doesn't really matter, as the pointer is only+        -- used for (bit/int)casting.+        tyAlias  = LMAlias (label `appendFS` structStr, LMStructU [])++        aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias+        -- we don't know the type of the indirectee here+        indType  = panic "will be filled by 'aliasify', later"+        orig     = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias++    pure ([LMGlobal aliasDef $ Just orig], [tyAlias])+ genLlvmData (sec, Statics lbl xs) = do     label <- strCLabel_llvm lbl     static <- mapM genData xs@@ -45,11 +74,10 @@     let types   = map getStatType static          strucTy = LMStruct types-        tyAlias = LMAlias ((label `appendFS` structStr), strucTy)+        tyAlias = LMAlias (label `appendFS` structStr, strucTy)          struct         = Just $ LMStaticStruc static tyAlias-        link           = if (externallyVisibleCLabel lbl)-                            then ExternallyVisible else Internal+        link           = linkage lbl         align          = case sec of                             Section CString _ -> Just 1                             _                 -> Nothing

@@ -71,7 +71,7 @@        let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect                               prefix lmblocks            name = decName $ funcDecl fun-           defName = name `appendFS` fsLit "$def"+           defName = llvmDefLabel name            funcDecl' = (funcDecl fun) { decName = defName }            fun' = fun { funcDecl = funcDecl' }            funTy = LMFunction funcDecl'

@@ -1218,17 +1218,8 @@          ghcVersionH <- liftIO $ getGhcVersionPathName dflags -        let gcc_lang_opt | cc_phase `eqPhase` Ccxx    = "c++"-                         | cc_phase `eqPhase` Cobjc   = "objective-c"-                         | cc_phase `eqPhase` Cobjcxx = "objective-c++"-                         | otherwise                  = "c"-        liftIO $ SysTools.runCc dflags (-                -- force the C compiler to interpret this file as C when-                -- compiling .hc files, by adding the -x c option.-                -- Also useful for plain .c files, just in case GHC saw a-                -- -x c option.-                        [ SysTools.Option "-x", SysTools.Option gcc_lang_opt-                        , SysTools.FileOption "" input_fn+        liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags (+                        [ SysTools.FileOption "" input_fn                         , SysTools.Option "-o"                         , SysTools.FileOption "" output_fn                         ]@@ -1917,7 +1908,7 @@     let verbFlags = getVerbFlags dflags      let cpp_prog args | raw       = SysTools.runCpp dflags args-                      | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)+                      | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args)      let target_defs =           [ "-D" ++ HOST_OS     ++ "_BUILD_OS",

@@ -313,8 +313,10 @@       , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")       ] -     hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)-               , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)+     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that+     -- when hiDir field is set in dflags, we know to look there (see #16500)+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)                ]          -- In compilation manager modes, we look for source files in the home@@ -488,6 +490,15 @@                         ml_hi_file   = hi_fn,                         ml_obj_file  = obj_fn,                         ml_hie_file  = hie_fn })++mkHomeModHiOnlyLocation :: DynFlags+                        -> ModuleName+                        -> FilePath+                        -> BaseName+                        -> IO ModLocation+mkHomeModHiOnlyLocation dflags mod path basename = do+   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""+   return loc { ml_hs_file = Nothing }  mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String                     -> IO ModLocation

@@ -1470,6 +1470,8 @@     let dflags = hsc_dflags hsc_env      let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds+    dumpIfSet_dyn dflags Opt_D_dump_stg_final+                  "STG for code gen:" (pprGenStgTopBindings stg_binds_w_fvs)     let cmm_stream :: Stream IO CmmGroup ()         cmm_stream = {-# SCC "StgCmm" #-}             StgCmm.codeGen dflags this_mod data_tycons

@@ -199,15 +199,9 @@        let unreg_gcc_args = if targetUnregisterised                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]                             else []-           -- TABLES_NEXT_TO_CODE affects the info table layout.-           tntc_gcc_args-            | mkTablesNextToCode targetUnregisterised-               = ["-DTABLES_NEXT_TO_CODE"]-            | otherwise = []            cpp_args= map Option (words cpp_args_str)            gcc_args = map Option (words gcc_args_str-                               ++ unreg_gcc_args-                               ++ tntc_gcc_args)+                               ++ unreg_gcc_args)        ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"        ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"@@ -301,6 +295,7 @@                     sOpt_P_fingerprint = fingerprint0,                     sOpt_F       = [],                     sOpt_c       = [],+                    sOpt_cxx     = [],                     sOpt_a       = [],                     sOpt_l       = [],                     sOpt_windres = [],

@@ -40,7 +40,7 @@       oFile <- newTempName dflags TFL_GhcSession "o"       writeFile cFile xs       ccInfo <- liftIO $ getCompilerInfo dflags-      runCc dflags+      runCc Nothing dflags             ([Option        "-c",               FileOption "" cFile,               Option        "-o",

@@ -10,6 +10,7 @@  import Exception import ErrUtils+import HscTypes import DynFlags import Outputable import Platform@@ -58,11 +59,12 @@       opts = map Option (getOpts dflags opt_F)   runSomething dflags "Haskell pre-processor" prog (args ++ opts) -runCc :: DynFlags -> [Option] -> IO ()-runCc dflags args =   do+-- | 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-      args1 = map Option (getOpts dflags opt_c)-      args2 = args0 ++ args ++ args1+      args1 = map Option userOpts+      args2 = args0 ++ 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@@ -117,6 +119,21 @@   wantedWarning w    | "warning: call-clobbered register used" `isContainedIn` w = False    | otherwise = True++  -- force the C compiler to interpret this file as C when+  -- compiling .hc files, by adding the -x c option.+  -- Also useful for plain .c files, just in case GHC saw a+  -- -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)+  userOpts_c   = getOpts dflags opt_c+  userOpts_cxx = getOpts dflags opt_cxx  isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)

@@ -179,7 +179,7 @@ x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)                                   X86.Instr.Instr X86.Instr.JumpDest x86NcgImpl dflags- = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }+ = (x86_64NcgImpl dflags)  x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)                                   X86.Instr.Instr X86.Instr.JumpDest@@ -194,7 +194,6 @@        ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl        ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags        ,allocatableRegs           = X86.Regs.allocatableRegs platform-       ,ncg_x86fp_kludge          = id        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform        ,ncgExpandTop              = id        ,ncgMakeFarBranches        = const id@@ -215,7 +214,6 @@        ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl        ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags        ,allocatableRegs           = PPC.Regs.allocatableRegs platform-       ,ncg_x86fp_kludge          = id        ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform        ,ncgExpandTop              = id        ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches@@ -236,7 +234,6 @@        ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl        ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags        ,allocatableRegs           = SPARC.Regs.allocatableRegs-       ,ncg_x86fp_kludge          = id        ,ncgAllocMoreStack         = noAllocMoreStack        ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop        ,ncgMakeFarBranches        = const id@@ -680,19 +677,10 @@                 foldl' (\m (from,to) -> addImmediateSuccessor from to m )                        cfgWithFixupBlks stack_updt_blks -        ---- x86fp_kludge.  This pass inserts ffree instructions to clear-        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack-        ---- is clear, and library functions can return odd results if it-        ---- isn't.-        -----        ---- NB. must happen before shortcutBranches, because that-        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.-        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced-         ---- generate jump tables         let tabled      =                 {-# SCC "generateJumpTables" #-}-                generateJumpTables ncgImpl kludged+                generateJumpTables ncgImpl alloced          dumpIfSet_dyn dflags                 Opt_D_dump_cfg_weights "CFG Update information"@@ -786,12 +774,6 @@         getBlockIds (CmmData _ _) = setEmpty         getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =                 setFromList $ map blockId blocks---x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr-x86fp_kludge top@(CmmData _ _) = top-x86fp_kludge (CmmProc info lbl live (ListGraph code)) =-        CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)  -- | Compute unwinding tables for the blocks of a procedure computeUnwinding :: Instruction instr

@@ -47,7 +47,6 @@         | II64         | FF32         | FF64-        | FF80         deriving (Show, Eq)  @@ -70,7 +69,7 @@  = case width of         W32     -> FF32         W64     -> FF64-        W80     -> FF80+         other   -> pprPanic "Format.floatFormat" (ppr other)  @@ -80,7 +79,6 @@  = case format of         FF32    -> True         FF64    -> True-        FF80    -> True         _       -> False  @@ -101,7 +99,7 @@         II64            -> W64         FF32            -> W32         FF64            -> W64-        FF80            -> W80+  formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth

@@ -76,7 +76,6 @@     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],-    ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr                               -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),

@@ -1593,7 +1593,7 @@     -> [CmmActual]        -- arguments (of mixed type)     -> NatM InstrBlock -{- +{-     PowerPC Linux uses the System V Release 4 Calling Convention     for PowerPC. It is described in the     "System V Application Binary Interface PowerPC Processor Supplement".@@ -1906,7 +1906,7 @@                           FF32 -> (1, 1, 4, fprs)                           FF64 -> (2, 1, 8, fprs)                           II64 -> panic "genCCall' passArguments II64"-                          FF80 -> panic "genCCall' passArguments FF80"+                       GCP32ELF ->                           case cmmTypeFormat rep of                           II8  -> (1, 0, 4, gprs)@@ -1916,7 +1916,6 @@                           FF32 -> (0, 1, 4, fprs)                           FF64 -> (0, 1, 8, fprs)                           II64 -> panic "genCCall' passArguments II64"-                          FF80 -> panic "genCCall' passArguments FF80"                       GCP64ELF _ ->                           case cmmTypeFormat rep of                           II8  -> (1, 0, 8, gprs)@@ -1928,7 +1927,6 @@                           -- the FPRs.                           FF32 -> (1, 1, 8, fprs)                           FF64 -> (1, 1, 8, fprs)-                          FF80 -> panic "genCCall' passArguments FF80"          moveResult reduceToFF32 =             case dest_regs of

@@ -27,6 +27,7 @@  import BlockId import CLabel+import PprCmmExpr ()  import Unique                ( pprUniqueAlways, getUnique ) import Platform@@ -119,6 +120,16 @@   pprDatas :: CmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)  pprData :: CmmStatic -> SDoc@@ -161,7 +172,7 @@       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u       RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u+   where     ppr_reg_no :: Int -> SDoc     ppr_reg_no i@@ -179,8 +190,7 @@                 II32 -> sLit "w"                 II64 -> sLit "d"                 FF32 -> sLit "fs"-                FF64 -> sLit "fd"-                _    -> panic "PPC.Ppr.pprFormat: no match")+                FF64 -> sLit "fd")   pprCond :: Cond -> SDoc@@ -365,7 +375,6 @@             II64 -> sLit "d"             FF32 -> sLit "fs"             FF64 -> sLit "fd"-            _         -> panic "PPC.Ppr.pprInstr: no match"             ),         case addr of AddrRegImm _ _ -> empty                      AddrRegReg _ _ -> char 'x',@@ -405,7 +414,6 @@             II64 -> sLit "d"             FF32 -> sLit "fs"             FF64 -> sLit "fd"-            _         -> panic "PPC.Ppr.pprInstr: no match"             ),         case addr of AddrRegImm _ _ -> empty                      AddrRegReg _ _ -> char 'x',

@@ -131,7 +131,7 @@         RcInteger       -> text "blue"         RcFloat         -> text "red"         RcDouble        -> text "green"-        RcDoubleSSE     -> text "yellow"+   -- immediates ------------------------------------------------------------------

@@ -56,7 +56,7 @@         | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register         | VirtualRegF  {-# UNPACK #-} !Unique         | VirtualRegD  {-# UNPACK #-} !Unique-        | VirtualRegSSE {-# UNPACK #-} !Unique+         deriving (Eq, Show)  -- This is laborious, but necessary. We can't derive Ord because@@ -69,17 +69,16 @@   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 (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b+   compare VirtualRegI{} _ = LT   compare _ VirtualRegI{} = GT   compare VirtualRegHi{} _ = LT   compare _ VirtualRegHi{} = GT   compare VirtualRegF{} _ = LT   compare _ VirtualRegF{} = GT-  compare VirtualRegD{} _ = LT-  compare _ VirtualRegD{} = GT  + instance Uniquable VirtualReg where         getUnique reg          = case reg of@@ -87,18 +86,20 @@                 VirtualRegHi u  -> u                 VirtualRegF u   -> u                 VirtualRegD u   -> u-                VirtualRegSSE u -> u  instance Outputable VirtualReg where         ppr reg          = case reg 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-                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u+                -- 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  + renameVirtualReg :: Unique -> VirtualReg -> VirtualReg renameVirtualReg u r  = case r of@@ -106,7 +107,6 @@         VirtualRegHi _  -> VirtualRegHi u         VirtualRegF _   -> VirtualRegF  u         VirtualRegD _   -> VirtualRegD  u-        VirtualRegSSE _ -> VirtualRegSSE u   classOfVirtualReg :: VirtualReg -> RegClass@@ -116,7 +116,7 @@         VirtualRegHi{}  -> RcInteger         VirtualRegF{}   -> RcFloat         VirtualRegD{}   -> RcDouble-        VirtualRegSSE{} -> RcDoubleSSE+   -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform

@@ -134,6 +134,10 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions         | let cALLOCATABLE_REGS_FLOAT                   =        (case platformArch platform of+                    -- On x86_64 and x86, Float and RcDouble+                    -- use the same registers,+                    -- so we only use RcDouble to represent the+                    -- register allocation problem on those types.                             ArchX86       -> 0                             ArchX86_64    -> 0                             ArchPPC       -> 0@@ -160,8 +164,14 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions         | let cALLOCATABLE_REGS_DOUBLE                   =        (case platformArch platform of-                            ArchX86       -> 6-                            ArchX86_64    -> 0+                            ArchX86       -> 8+                            -- in x86 32bit mode sse2 there are only+                            -- 8 XMM registers xmm0 ... xmm7+                            ArchX86_64    -> 10+                            -- in x86_64 there are 16 XMM registers+                            -- xmm0 .. xmm15, here 10 is a+                            -- "dont need to solve conflicts" count that+                            -- was chosen at some point in the past.                             ArchPPC       -> 26                             ArchSPARC     -> 11                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"@@ -183,31 +193,7 @@          = count3 < cALLOCATABLE_REGS_DOUBLE -trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions-        | let cALLOCATABLE_REGS_SSE-                  =        (case platformArch platform of-                            ArchX86       -> 8-                            ArchX86_64    -> 10-                            ArchPPC       -> 0-                            ArchSPARC     -> 0-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"-                            ArchPPC_64 _  -> 0-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchARM64     -> panic "trivColorable ArchARM64"-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"-                            ArchUnknown   -> panic "trivColorable ArchUnknown")-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_SSE-                                (virtualRegSqueeze RcDoubleSSE)-                                conflicts -        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_SSE-                                (realRegSqueeze   RcDoubleSSE)-                                exclusions--        = count3 < cALLOCATABLE_REGS_SSE   -- Specification Code ----------------------------------------------------------

@@ -18,7 +18,6 @@         = RcInteger         | RcFloat         | RcDouble-        | RcDoubleSSE -- x86 only: the SSE regs are a separate class         deriving Eq  @@ -26,10 +25,8 @@     getUnique RcInteger = mkRegClassUnique 0     getUnique RcFloat   = mkRegClassUnique 1     getUnique RcDouble  = mkRegClassUnique 2-    getUnique RcDoubleSSE = mkRegClassUnique 3  instance Outputable RegClass where     ppr RcInteger       = Outputable.text "I"     ppr RcFloat         = Outputable.text "F"     ppr RcDouble        = Outputable.text "D"-    ppr RcDoubleSSE     = Outputable.text "S"

@@ -384,7 +384,6 @@                         RcInteger -> II32                         RcFloat   -> FF32                         RcDouble  -> FF64-                        _         -> panic "sparc_mkSpillInstr"      in ST fmt reg (fpRel (negate off_w)) @@ -405,7 +404,6 @@                         RcInteger -> II32                         RcFloat   -> FF32                         RcDouble  -> FF64-                        _         -> panic "sparc_mkLoadInstr"          in LD fmt (fpRel (- off_w)) reg @@ -454,7 +452,6 @@                 RcInteger -> ADD  False False src (RIReg g0) dst                 RcDouble  -> FMOV FF64 src dst                 RcFloat   -> FMOV FF32 src dst-                _         -> panic "sparc_mkRegRegMoveInstr"          | otherwise         = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"

@@ -102,6 +102,16 @@   pprDatas :: CmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)  pprData :: CmmStatic -> SDoc@@ -143,8 +153,8 @@                 VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u                 VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u                 VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u-                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u +         RegReal rr          -> case rr of                 RealRegSingle r1@@ -211,8 +221,7 @@         II32    -> sLit ""         II64    -> sLit "d"         FF32    -> sLit ""-        FF64    -> sLit "d"-        _       -> panic "SPARC.Ppr.pprFormat: no match")+        FF64    -> sLit "d")   -- | Pretty print a format for an instruction suffix.@@ -226,10 +235,10 @@         II32  -> sLit ""         II64  -> sLit "x"         FF32  -> sLit ""-        FF64  -> sLit "d"-        _       -> panic "SPARC.Ppr.pprFormat: no match")+        FF64  -> sLit "d")  + -- | Pretty print a condition code. pprCond :: Cond -> SDoc pprCond c@@ -635,4 +644,3 @@  pp_comma_a :: SDoc pp_comma_a        = text ",a"-

@@ -104,7 +104,6 @@                 VirtualRegD{}           -> 1                 _other                  -> 0 -        _other -> 0  {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int@@ -135,7 +134,6 @@                  RealRegPair{}           -> 1 -        _other -> 0  -- | All the allocatable registers in the machine, --      including register pairs.

@@ -98,17 +98,25 @@ sse2Enabled :: NatM Bool sse2Enabled = do   dflags <- getDynFlags-  return (isSse2Enabled dflags)+  case platformArch (targetPlatform dflags) of+  -- We Assume  SSE1 and SSE2 operations are available on both+  -- x86 and x86_64. Historically we didn't default to SSE2 and+  -- SSE1 on x86, which results in defacto nondeterminism for how+  -- rounding behaves in the associated x87 floating point instructions+  -- because variations in the spill/fpu stack placement of arguments for+  -- operations would change the precision and final result of what+  -- would otherwise be the same expressions with respect to single or+  -- double precision IEEE floating point computations.+    ArchX86_64 -> return True+    ArchX86    -> return True+    _          -> panic "trying to generate x86/x86_64 on the wrong platform" + sse4_2Enabled :: NatM Bool sse4_2Enabled = do   dflags <- getDynFlags   return (isSse4_2Enabled dflags) -if_sse2 :: NatM a -> NatM a -> NatM a-if_sse2 sse2 x87 = do-  b <- sse2Enabled-  if b then sse2 else x87  cmmTopCodeGen         :: RawCmmDecl@@ -128,7 +136,7 @@       Nothing -> return tops  cmmTopCodeGen (CmmData sec dat) = do-  return [CmmData sec (1, dat)]  -- no translation, we just use CmmStatic+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic   basicBlockCodeGen@@ -284,15 +292,14 @@   -- | Grab the Reg for a CmmReg-getRegisterReg :: Platform -> Bool -> CmmReg -> Reg+getRegisterReg :: Platform  -> CmmReg -> Reg -getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk))-  = let fmt = cmmTypeFormat pk in-    if isFloatFormat fmt && not use_sse2-       then RegVirtual (mkVirtualReg u FF80)-       else RegVirtual (mkVirtualReg u fmt)+getRegisterReg _   (CmmLocal (LocalReg u pk))+  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated+   let fmt = cmmTypeFormat pk in+        RegVirtual (mkVirtualReg u fmt) -getRegisterReg platform _ (CmmGlobal mid)+getRegisterReg platform  (CmmGlobal mid)   = case globalRegMaybe platform mid of         Just reg -> RegReal $ reg         Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)@@ -513,15 +520,14 @@             do reg' <- getPicBaseNat (archWordFormat is32Bit)                return (Fixed (archWordFormat is32Bit) reg' nilOL)         _ ->-            do use_sse2 <- sse2Enabled+            do                let                  fmt = cmmTypeFormat (cmmRegType dflags reg)-                 format | not use_sse2 && isFloatFormat fmt = FF80-                        | otherwise                         = fmt+                 format  = fmt                --                let platform = targetPlatform dflags                return (Fixed format-                             (getRegisterReg platform use_sse2 reg)+                             (getRegisterReg platform  reg)                              nilOL)  @@ -557,8 +563,7 @@   return $ Fixed II32 rlo code  getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =-  if_sse2 float_const_sse2 float_const_x87- where+  float_const_sse2  where   float_const_sse2     | f == 0.0 = do       let@@ -569,22 +574,8 @@       return (Any format code)     | otherwise = do-      Amode addr code <- memConstant (widthInBytes w) lit-      loadFloatAmode True w addr code--  float_const_x87 = case w of-    W64-      | f == 0.0 ->-        let code dst = unitOL (GLDZ dst)-        in  return (Any FF80 code)--      | f == 1.0 ->-        let code dst = unitOL (GLD1 dst)-        in  return (Any FF80 code)--    _otherwise -> do-      Amode addr code <- memConstant (widthInBytes w) lit-      loadFloatAmode False w addr code+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      loadFloatAmode w addr code  -- catch simple cases of zero- or sign-extended load getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do@@ -641,12 +632,10 @@         LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))  getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps-    sse2 <- sse2Enabled     case mop of-      MO_F_Neg w-         | sse2      -> sse2NegCode w x-         | otherwise -> trivialUFCode FF80 (GNEG FF80) x+      MO_F_Neg w  -> sse2NegCode w x +       MO_S_Neg w -> triv_ucode NEGI (intFormat w)       MO_Not w   -> triv_ucode NOT  (intFormat w) @@ -711,10 +700,9 @@       MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x       MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x -      MO_FF_Conv W32 W64-        | sse2      -> coerceFP2FP W64 x-        | otherwise -> conversionNop FF80 x+      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x +       MO_FF_Conv W64 W32 -> coerceFP2FP W32 x        MO_FS_Conv from to -> coerceFP2Int from to x@@ -776,7 +764,6 @@   getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps-  sse2 <- sse2Enabled   case mop of       MO_F_Eq _ -> condFltReg is32Bit EQQ x y       MO_F_Ne _ -> condFltReg is32Bit NE  x y@@ -800,15 +787,15 @@       MO_U_Lt _ -> condIntReg LU  x y       MO_U_Le _ -> condIntReg LEU x y -      MO_F_Add w  | sse2      -> trivialFCode_sse2 w ADD  x y-                  | otherwise -> trivialFCode_x87    GADD x y-      MO_F_Sub w  | sse2      -> trivialFCode_sse2 w SUB  x y-                  | otherwise -> trivialFCode_x87    GSUB x y-      MO_F_Quot w | sse2      -> trivialFCode_sse2 w FDIV x y-                  | otherwise -> trivialFCode_x87    GDIV x y-      MO_F_Mul w  | sse2      -> trivialFCode_sse2 w MUL x y-                  | otherwise -> trivialFCode_x87    GMUL x y+      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y +      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y++      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y++      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y++       MO_Add rep -> add_code rep x y       MO_Sub rep -> sub_code rep x y @@ -1001,8 +988,7 @@   | isFloatType pk   = do     Amode addr mem_code <- getAmode mem-    use_sse2 <- sse2Enabled-    loadFloatAmode use_sse2 (typeWidth pk) addr mem_code+    loadFloatAmode  (typeWidth pk) addr mem_code  getRegister' _ is32Bit (CmmLoad mem pk)   | is32Bit && not (isWord64 pk)@@ -1132,9 +1118,7 @@                 return (reg, code)  reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst-  | format == FF80 = GMOV src dst-  | otherwise    = MOV format (OpReg src) (OpReg dst)+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)   --------------------------------------------------------------------------------@@ -1243,11 +1227,10 @@  getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand (CmmLit lit) = do-  use_sse2 <- sse2Enabled-  if use_sse2 && isSuitableFloatingPointLit lit+  if  isSuitableFloatingPointLit lit     then do       let CmmFloat _ w = lit-      Amode addr code <- memConstant (widthInBytes w) lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit       return (OpAddr addr, code)      else do @@ -1259,9 +1242,12 @@  getNonClobberedOperand (CmmLoad mem pk) = do   is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2)-      && (if is32Bit then not (isWord64 pk) else True)+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 pk) else True)+      -- if 32bit and pk is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later     then do       dflags <- getDynFlags       let platform = targetPlatform dflags@@ -1278,6 +1264,7 @@                    return (src, nilOL)       return (OpAddr src', mem_code `appOL` save_code)     else do+      -- if its a word or gcptr on 32bit?       getNonClobberedOperand_generic (CmmLoad mem pk)  getNonClobberedOperand e = getNonClobberedOperand_generic e@@ -1303,7 +1290,7 @@   if (use_sse2 && isSuitableFloatingPointLit lit)     then do       let CmmFloat _ w = lit-      Amode addr code <- memConstant (widthInBytes w) lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit       return (OpAddr addr, code)     else do @@ -1351,7 +1338,7 @@              , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel              ] -memConstant :: Int -> CmmLit -> NatM Amode+memConstant :: Alignment -> CmmLit -> NatM Amode memConstant align lit = do   lbl <- getNewLabelNat   let rosection = Section ReadOnlyData lbl@@ -1370,16 +1357,15 @@   return (Amode addr code)  -loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode use_sse2 w addr addr_code = do+loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode w addr addr_code = do   let format = floatFormat w       code dst = addr_code `snocOL`-                 if use_sse2-                    then MOV format (OpAddr addr) (OpReg dst)-                    else GLD format addr dst-  return (Any (if use_sse2 then format else FF80) code)+                    MOV format (OpAddr addr) (OpReg dst) +  return (Any format code) + -- if we want a floating-point literal as an operand, we can -- use it directly from memory.  However, if the literal is -- zero, we're better off generating it into a register using@@ -1538,19 +1524,9 @@ condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode  condFltCode cond x y-  = if_sse2 condFltCode_sse2 condFltCode_x87+  =  condFltCode_sse2   where -  condFltCode_x87-    = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do-    (x_reg, x_code) <- getNonClobberedReg x-    (y_reg, y_code) <- getSomeReg y-    let-        code = x_code `appOL` y_code `snocOL`-                GCMP cond x_reg y_reg-    -- The GCMP insn does the test and sets the zero flag if comparable-    -- and true.  Hence we always supply EQQ as the condition to test.-    return (CondCode True EQQ code)    -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be   -- an operand, but the right must be a reg.  We can probably do better@@ -1634,35 +1610,33 @@   load_code <- intLoadCode (MOV pk) src   dflags <- getDynFlags   let platform = targetPlatform dflags-  return (load_code (getRegisterReg platform False{-no sse2-} reg))+  return (load_code (getRegisterReg platform reg))  -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do   dflags <- getDynFlags   let platform = targetPlatform dflags   code <- getAnyReg src-  return (code (getRegisterReg platform False{-no sse2-} reg))+  return (code (getRegisterReg platform reg))   -- Floating point assignment to memory assignMem_FltCode pk addr src = do   (src_reg, src_code) <- getNonClobberedReg src   Amode addr addr_code <- getAmode addr-  use_sse2 <- sse2Enabled   let         code = src_code `appOL`                addr_code `snocOL`-                if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr)-                            else GST pk src_reg addr+               MOV pk (OpReg src_reg) (OpAddr addr)+   return code  -- Floating point assignment to a register/temporary assignReg_FltCode _ reg src = do-  use_sse2 <- sse2Enabled   src_code <- getAnyReg src   dflags <- getDynFlags   let platform = targetPlatform dflags-  return (src_code (getRegisterReg platform use_sse2 reg))+  return (src_code (getRegisterReg platform  reg))   genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock@@ -1793,12 +1767,11 @@  -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --- Unroll memcpy calls if the source and destination pointers are at--- least DWORD aligned and the number of bytes to copy isn't too+-- Unroll memcpy calls if the number of bytes to copy isn't too -- large.  Otherwise, call C's memcpy.-genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _+genCCall dflags _ (PrimTarget (MO_Memcpy align)) _          [dst, src, CmmLit (CmmInt n _)] _-    | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do+    | fromInteger insns <= maxInlineMemcpyInsns dflags = do         code_dst <- getAnyReg dst         dst_r <- getNewRegNat format         code_src <- getAnyReg src@@ -1811,7 +1784,9 @@     -- instructions per move.     insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) -    format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit)+    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment      -- The size of each move, in bytes.     sizeBytes :: Integer@@ -1848,17 +1823,25 @@           CmmLit (CmmInt c _),           CmmLit (CmmInt n _)]          _-    | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do+    | fromInteger insns <= maxInlineMemsetInsns dflags = do         code_dst <- getAnyReg dst         dst_r <- getNewRegNat format-        return $ code_dst dst_r `appOL` go dst_r (fromInteger n)+        if format == II64 && n >= 8 then do+          code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+          imm8byte_r <- getNewRegNat II64+          return $ code_dst dst_r `appOL`+                   code_imm8byte imm8byte_r `appOL`+                   go8 dst_r imm8byte_r (fromInteger n)+        else+          return $ code_dst dst_r `appOL`+                   go4 dst_r (fromInteger n)   where-    (format, val) = case align .&. 3 of-        2 -> (II16, c2)-        0 -> (II32, c4)-        _ -> (II8, c)+    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment     c2 = c `shiftL` 8 .|. c     c4 = c2 `shiftL` 16 .|. c2+    c8 = c4 `shiftL` 32 .|. c4      -- The number of instructions we will generate (approx). We need 1     -- instructions per move.@@ -1868,26 +1851,46 @@     sizeBytes :: Integer     sizeBytes = fromIntegral (formatInBytes format) -    go :: Reg -> Integer -> OrdList Instr-    go dst i-        -- TODO: Add movabs instruction and support 64-bit sets.-        | i >= sizeBytes =  -- This might be smaller than the below sizes-            unitOL (MOV format (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL`-            go dst (i - sizeBytes)-        | i >= 4 =  -- Will never happen on 32-bit-            unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL`-            go dst (i - 4)-        | i >= 2 =-            unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL`-            go dst (i - 2)-        | i >= 1 =-            unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL`-            go dst (i - 1)-        | otherwise = nilOL+    -- Depending on size returns the widest MOV instruction and its+    -- width.+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+    gen4 addr size+        | size >= 4 =+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+        | size >= 2 =+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+        | size >= 1 =+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+        | otherwise = (nilOL, 0)++    -- Generates a 64-bit wide MOV instruction from REG to MEM.+    gen8 :: AddrMode -> Reg -> InstrBlock+    gen8 addr reg8byte =+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++    -- Unrolls memset when the widest MOV is <= 4 bytes.+    go4 :: Reg -> Integer -> InstrBlock+    go4 dst left =+      if left <= 0 then nilOL+      else curMov `appOL` go4 dst (left - curWidth)       where-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone-                   (ImmInteger (n - i))+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+        (curMov, curWidth) = gen4 dst_addr possibleWidth +    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+    -- argument). Falls back to go4 when all 8 byte moves are+    -- exhausted.+    go8 :: Reg -> Reg -> Integer -> InstrBlock+    go8 dst reg8byte left =+      if possibleWidth >= 8 then+        let curMov = gen8 dst_addr reg8byte+        in  curMov `appOL` go8 dst reg8byte (left - 8)+      else go4 dst left+      where+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+ genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL         -- write barrier compiles to no code on x86/x86-64;         -- we keep it this long in order to prevent earlier optimisations.@@ -1917,7 +1920,7 @@  genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do     let platform = targetPlatform dflags-    let dst_r = getRegisterReg platform False (CmmLocal dst)+    let dst_r = getRegisterReg platform (CmmLocal dst)     case width of         W64 | is32Bit -> do                ChildCode64 vcode rlo <- iselExpr64 src@@ -1944,7 +1947,7 @@     if sse4_2         then do code_src <- getAnyReg src                 src_r <- getNewRegNat format-                let dst_r = getRegisterReg platform False (CmmLocal dst)+                let dst_r = getRegisterReg platform  (CmmLocal dst)                 return $ code_src src_r `appOL`                     (if width == W8 then                          -- The POPCNT instruction doesn't take a r/m8@@ -1976,7 +1979,7 @@                 code_mask <- getAnyReg mask                 src_r     <- getNewRegNat format                 mask_r    <- getNewRegNat format-                let dst_r = getRegisterReg platform False (CmmLocal dst)+                let dst_r = getRegisterReg platform  (CmmLocal dst)                 return $ code_src src_r `appOL` code_mask mask_r `appOL`                     (if width == W8 then                          -- The PDEP instruction doesn't take a r/m8@@ -2009,7 +2012,7 @@                 code_mask <- getAnyReg mask                 src_r     <- getNewRegNat format                 mask_r    <- getNewRegNat format-                let dst_r = getRegisterReg platform False (CmmLocal dst)+                let dst_r = getRegisterReg platform  (CmmLocal dst)                 return $ code_src src_r `appOL` code_mask mask_r `appOL`                     (if width == W8 then                          -- The PEXT instruction doesn't take a r/m8@@ -2045,7 +2048,7 @@    | otherwise = do     code_src <- getAnyReg src-    let dst_r = getRegisterReg platform False (CmmLocal dst)+    let dst_r = getRegisterReg platform (CmmLocal dst)     if isBmi2Enabled dflags         then do             src_r <- getNewRegNat (intFormat width)@@ -2082,7 +2085,7 @@   | is32Bit, width == W64 = do       ChildCode64 vcode rlo <- iselExpr64 src       let rhi     = getHiVRegFromLo rlo-          dst_r   = getRegisterReg platform False (CmmLocal dst)+          dst_r   = getRegisterReg platform  (CmmLocal dst)       lbl1 <- getBlockIdNat       lbl2 <- getBlockIdNat       let format = if width == W8 then II16 else intFormat width@@ -2122,7 +2125,7 @@    | otherwise = do     code_src <- getAnyReg src-    let dst_r = getRegisterReg platform False (CmmLocal dst)+    let dst_r = getRegisterReg platform (CmmLocal dst)      if isBmi2Enabled dflags     then do@@ -2173,9 +2176,8 @@         else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg     arg <- getNewRegNat format     arg_code <- getAnyReg n-    use_sse2 <- sse2Enabled     let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+        dst_r    = getRegisterReg platform  (CmmLocal dst)     code <- op_code dst_r arg amode     return $ addr_code `appOL` arg_code arg `appOL` code   where@@ -2232,9 +2234,9 @@ genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do   load_code <- intLoadCode (MOV (intFormat width)) addr   let platform = targetPlatform dflags-  use_sse2 <- sse2Enabled-  return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) +  return (load_code (getRegisterReg platform  (CmmLocal dst)))+ genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do     code <- assignMem_IntCode (intFormat width) addr val     return $ code `snocOL` MFENCE@@ -2248,9 +2250,8 @@     newval_code <- getAnyReg new     oldval <- getNewRegNat format     oldval_code <- getAnyReg old-    use_sse2 <- sse2Enabled     let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+        dst_r    = getRegisterReg platform  (CmmLocal dst)         code     = toOL                    [ MOV format (OpReg oldval) (OpReg eax)                    , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))@@ -2264,14 +2265,12 @@ genCCall _ is32Bit target dest_regs args bid = do   dflags <- getDynFlags   let platform = targetPlatform dflags-      sse2     = isSse2Enabled dflags   case (target, dest_regs) of     -- void return type prim op     (PrimTarget op, []) ->         outOfLineCmmOp bid op Nothing args     -- we only cope with a single result for foreign calls-    (PrimTarget op, [r])-      | sse2 -> case op of+    (PrimTarget op, [r])  -> case op of           MO_F32_Fabs -> case args of             [x] -> sse2FabsCode W32 x             _ -> panic "genCCall: Wrong number of arguments for fabs"@@ -2282,36 +2281,16 @@           MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args           MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args           _other_op -> outOfLineCmmOp bid op (Just r) args-      | otherwise -> do-        l1 <- getNewLabelNat-        l2 <- getNewLabelNat-        if sse2-          then outOfLineCmmOp bid op (Just r) args-          else case op of-              MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args-              MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args -              MO_F32_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args-              MO_F64_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args--              MO_F32_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args-              MO_F64_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args--              MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args-              MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args--              _other_op   -> outOfLineCmmOp bid op (Just r) args-        where-        actuallyInlineFloatOp = actuallyInlineFloatOp' False-        actuallyInlineSSE2Op = actuallyInlineFloatOp' True+        actuallyInlineSSE2Op = actuallyInlineFloatOp' -        actuallyInlineFloatOp' usesSSE instr format [x]+        actuallyInlineFloatOp'  instr format [x]               = do res <- trivialUFCode format (instr format) x                    any <- anyReg res-                   return (any (getRegisterReg platform usesSSE (CmmLocal r)))+                   return (any (getRegisterReg platform  (CmmLocal r))) -        actuallyInlineFloatOp' _ _ _ args+        actuallyInlineFloatOp' _ _ args               = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("                       ++ show (length args) ++ ")" @@ -2322,7 +2301,7 @@           let             const | FF32 <- fmt = CmmInt 0x7fffffff W32                   | otherwise   = CmmInt 0x7fffffffffffffff W64-          Amode amode amode_code <- memConstant (widthInBytes w) const+          Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const           tmp <- getNewRegNat fmt           let             code dst = x_code dst `appOL` amode_code `appOL` toOL [@@ -2330,7 +2309,7 @@                 AND fmt (OpReg tmp) (OpReg dst)                 ] -          return $ code (getRegisterReg platform True (CmmLocal r))+          return $ code (getRegisterReg platform (CmmLocal r))      (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args     (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args@@ -2342,8 +2321,8 @@                let format = intFormat width                lCode <- anyReg =<< trivialCode width (ADD_CC format)                                      (Just (ADD_CC format)) arg_x arg_y-               let reg_l = getRegisterReg platform True (CmmLocal res_l)-                   reg_h = getRegisterReg platform True (CmmLocal res_h)+               let reg_l = getRegisterReg platform (CmmLocal res_l)+                   reg_h = getRegisterReg platform (CmmLocal res_h)                    code = hCode reg_h `appOL`                           lCode reg_l `snocOL`                           ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)@@ -2363,8 +2342,8 @@             do (y_reg, y_code) <- getRegOrMem arg_y                x_code <- getAnyReg arg_x                let format = intFormat width-                   reg_h = getRegisterReg platform True (CmmLocal res_h)-                   reg_l = getRegisterReg platform True (CmmLocal res_l)+                   reg_h = getRegisterReg platform (CmmLocal res_h)+                   reg_l = getRegisterReg platform (CmmLocal res_l)                    code = y_code `appOL`                           x_code rax `appOL`                           toOL [MUL2 format y_reg,@@ -2400,8 +2379,8 @@         divOp platform signed width [res_q, res_r]               m_arg_x_high arg_x_low arg_y             = do let format = intFormat width-                     reg_q = getRegisterReg platform True (CmmLocal res_q)-                     reg_r = getRegisterReg platform True (CmmLocal res_r)+                     reg_q = getRegisterReg platform (CmmLocal res_q)+                     reg_r = getRegisterReg platform (CmmLocal res_r)                      widen | signed    = CLTD format                            | otherwise = XOR format (OpReg rdx) (OpReg rdx)                      instr | signed    = IDIV@@ -2428,8 +2407,8 @@                  rCode <- anyReg =<< trivialCode width (instr format)                                        (mrevinstr format) arg_x arg_y                  reg_tmp <- getNewRegNat II8-                 let reg_c = getRegisterReg platform True (CmmLocal res_c)-                     reg_r = getRegisterReg platform True (CmmLocal res_r)+                 let reg_c = getRegisterReg platform  (CmmLocal res_c)+                     reg_r = getRegisterReg platform  (CmmLocal res_r)                      code = rCode reg_r `snocOL`                             SETCC cond (OpReg reg_tmp) `snocOL`                             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)@@ -2473,8 +2452,7 @@         delta0 <- getDeltaNat         setDeltaNat (delta0 - arg_pad_size) -        use_sse2 <- sse2Enabled-        push_codes <- mapM (push_arg use_sse2) (reverse prom_args)+        push_codes <- mapM push_arg (reverse prom_args)         delta <- getDeltaNat         MASSERT(delta == delta0 - tot_arg_size) @@ -2527,18 +2505,21 @@             assign_code []     = nilOL             assign_code [dest]               | isFloatType ty =-                 if use_sse2-                    then let tmp_amode = AddrBaseIndex (EABaseReg esp)+                  -- we assume SSE2+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)                                                        EAIndexNone                                                        (ImmInt 0)-                             fmt = floatFormat w+                      fmt = floatFormat w                          in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),                                    DELTA (delta0 - b),-                                   GST fmt fake0 tmp_amode,+                                   X87Store fmt  tmp_amode,+                                   -- X87Store only supported for the CDECL ABI+                                   -- NB: This code will need to be+                                   -- revisted once GHC does more work around+                                   -- SIGFPE f                                    MOV fmt (OpAddr tmp_amode) (OpReg r_dest),                                    ADD II32 (OpImm (ImmInt b)) (OpReg esp),                                    DELTA delta0]-                    else unitOL (GMOV fake0 r_dest)               | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),                                         MOV II32 (OpReg edx) (OpReg r_dest_hi)]               | otherwise      = unitOL (MOV (intFormat w)@@ -2549,7 +2530,7 @@                     w  = typeWidth ty                     b  = widthInBytes w                     r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getRegisterReg platform use_sse2 (CmmLocal dest)+                    r_dest    = getRegisterReg platform  (CmmLocal dest)             assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)          return (push_code `appOL`@@ -2564,10 +2545,10 @@         roundTo a x | x `mod` a == 0 = x                     | otherwise = x + a - (x `mod` a) -        push_arg :: Bool -> CmmActual {-current argument-}+        push_arg :: CmmActual {-current argument-}                         -> NatM InstrBlock  -- code -        push_arg use_sse2 arg -- we don't need the hints on x86+        push_arg  arg -- we don't need the hints on x86           | isWord64 arg_ty = do             ChildCode64 code r_lo <- iselExpr64 arg             delta <- getDeltaNat@@ -2591,9 +2572,10 @@                                                             (ImmInt 0)                                       format = floatFormat (typeWidth arg_ty)                                   in-                                  if use_sse2-                                     then MOV format (OpReg reg) (OpAddr addr)-                                     else GST format reg addr++                                  -- assume SSE2+                                   MOV format (OpReg reg) (OpAddr addr)+                                  ]                            ) @@ -2721,7 +2703,7 @@                 _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))           where                 rep = localRegType dest-                r_dest = getRegisterReg platform True (CmmLocal dest)+                r_dest = getRegisterReg platform  (CmmLocal dest)         assign_code _many = panic "genCCall.assign_code many"      return (adjust_rsp          `appOL`@@ -3051,7 +3033,7 @@                           where blockLabel = blockLbl blockid                   in map jumpTableEntryRel ids             | otherwise = map (jumpTableEntry dflags) ids-      in CmmData section (1, Statics lbl jumpTable)+      in CmmData section (mkAlignment 1, Statics lbl jumpTable)  extractUnwindPoints :: [Instr] -> [UnwindPoint] extractUnwindPoints instrs =@@ -3134,18 +3116,10 @@ -- and plays better with the uOP cache.  condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87+condFltReg is32Bit cond x y = condFltReg_sse2  where-  condFltReg_x87 = do-    CondCode _ cond cond_code <- condFltCode cond x y-    tmp <- getNewRegNat II8-    let-        code dst = cond_code `appOL` toOL [-                    SETCC cond (OpReg tmp),-                    MOVZxL II8 (OpReg tmp) (OpReg dst)-                  ]-    return (Any II32 code) +   condFltReg_sse2 = do     CondCode _ cond cond_code <- condFltCode cond x y     tmp1 <- getNewRegNat (archWordFormat is32Bit)@@ -3308,18 +3282,6 @@  ----------- -trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr)-                 -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_x87 instr x y = do-  (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too-  (y_reg, y_code) <- getSomeReg y-  let-     format = FF80 -- always, on x87-     code dst =-        x_code `appOL`-        y_code `snocOL`-        instr format x_reg y_reg dst-  return (Any format code)  trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)                   -> CmmExpr -> CmmExpr -> NatM Register@@ -3340,17 +3302,8 @@  -------------------------------------------------------------------------------- coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87+coerceInt2FP from to x =  coerce_sse2  where-   coerce_x87 = do-     (x_reg, x_code) <- getSomeReg x-     let-           opc  = case to of W32 -> GITOF; W64 -> GITOD;-                             n -> panic $ "coerceInt2FP.x87: unhandled width ("-                                         ++ show n ++ ")"-           code dst = x_code `snocOL` opc x_reg dst-        -- ToDo: works for non-II32 reps?-     return (Any FF80 code)     coerce_sse2 = do      (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand@@ -3364,18 +3317,8 @@  -------------------------------------------------------------------------------- coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87+coerceFP2Int from to x =  coerceFP2Int_sse2  where-   coerceFP2Int_x87 = do-     (x_reg, x_code) <- getSomeReg x-     let-           opc  = case from of W32 -> GFTOI; W64 -> GDTOI-                               n -> panic $ "coerceFP2Int.x87: unhandled width ("-                                           ++ show n ++ ")"-           code dst = x_code `snocOL` opc x_reg dst-        -- ToDo: works for non-II32 reps?-     return (Any (intFormat to) code)-    coerceFP2Int_sse2 = do      (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand      let@@ -3390,15 +3333,13 @@ -------------------------------------------------------------------------------- coerceFP2FP :: Width -> CmmExpr -> NatM Register coerceFP2FP to x = do-  use_sse2 <- sse2Enabled   (x_reg, x_code) <- getSomeReg x   let-        opc | use_sse2  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;                                      n -> panic $ "coerceFP2FP: unhandled width ("                                                  ++ show n ++ ")"-            | otherwise = GDTOF         code dst = x_code `snocOL` opc x_reg dst-  return (Any (if use_sse2 then floatFormat to else FF80) code)+  return (Any ( floatFormat to) code)  -------------------------------------------------------------------------------- @@ -3415,10 +3356,10 @@       x@II16 -> wrongFmt x       x@II32 -> wrongFmt x       x@II64 -> wrongFmt x-      x@FF80 -> wrongFmt x+       where         wrongFmt x = panic $ "sse2NegCode: " ++ show x-  Amode amode amode_code <- memConstant (widthInBytes w) const+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const   tmp <- getNewRegNat fmt   let     code dst = x_code dst `appOL` amode_code `appOL` toOL [

@@ -10,7 +10,7 @@  module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..),                   getJumpDestBlockId, canShortcut, shortcutStatics,-                  shortcutJump, i386_insert_ffrees, allocMoreStack,+                  shortcutJump, allocMoreStack,                   maxSpillSlots, archWordFormat ) where @@ -240,46 +240,14 @@         | BT          Format Imm Operand         | NOP -        -- x86 Float Arithmetic.-        -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles-        -- as single instructions right up until we spit them out.-        -- all the 3-operand fake fp insns are src1 src2 dst-        -- and furthermore are constrained to be fp regs only.-        -- IMPORTANT: keep is_G_insn up to date with any changes here-        | GMOV        Reg Reg -- src(fpreg), dst(fpreg)-        | GLD         Format AddrMode Reg -- src, dst(fpreg)-        | GST         Format Reg AddrMode -- src(fpreg), dst -        | GLDZ        Reg -- dst(fpreg)-        | GLD1        Reg -- dst(fpreg)--        | GFTOI       Reg Reg -- src(fpreg), dst(intreg)-        | GDTOI       Reg Reg -- src(fpreg), dst(intreg)--        | GITOF       Reg Reg -- src(intreg), dst(fpreg)-        | GITOD       Reg Reg -- src(intreg), dst(fpreg)--        | GDTOF       Reg Reg -- src(fpreg), dst(fpreg)--        | GADD        Format Reg Reg Reg -- src1, src2, dst-        | GDIV        Format Reg Reg Reg -- src1, src2, dst-        | GSUB        Format Reg Reg Reg -- src1, src2, dst-        | GMUL        Format Reg Reg Reg -- src1, src2, dst--                -- FP compare.  Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]-                -- Compare src1 with src2; set the Zero flag iff the numbers are-                -- comparable and the comparison is True.  Subsequent code must-                -- test the %eflags zero flag regardless of the supplied Cond.-        | GCMP        Cond Reg Reg -- src1, src2--        | GABS        Format Reg Reg -- src, dst-        | GNEG        Format Reg Reg -- src, dst-        | GSQRT       Format Reg Reg -- src, dst-        | GSIN        Format CLabel CLabel Reg Reg -- src, dst-        | GCOS        Format CLabel CLabel Reg Reg -- src, dst-        | GTAN        Format CLabel CLabel Reg Reg -- src, dst--        | GFREE         -- do ffree on all x86 regs; an ugly hack+        -- We need to support the FSTP (x87 store and pop) instruction+        -- so that we can correctly read off the return value of an+        -- x86 CDECL C function call when its floating point.+        -- so we dont include a register argument, and just use st(0)+        -- this instruction is used ONLY for return values of C ffi calls+        -- in x86_32 abi+        | X87Store         Format  AddrMode -- st(0), dst           -- SSE2 floating point: we use a restricted set of the available SSE2@@ -427,33 +395,7 @@     CLTD   _            -> mkRU [eax] [edx]     NOP                 -> mkRU [] [] -    GMOV   src dst      -> mkRU [src] [dst]-    GLD    _ src dst    -> mkRU (use_EA src []) [dst]-    GST    _ src dst    -> mkRUR (src : use_EA dst [])--    GLDZ   dst          -> mkRU [] [dst]-    GLD1   dst          -> mkRU [] [dst]--    GFTOI  src dst      -> mkRU [src] [dst]-    GDTOI  src dst      -> mkRU [src] [dst]--    GITOF  src dst      -> mkRU [src] [dst]-    GITOD  src dst      -> mkRU [src] [dst]--    GDTOF  src dst      -> mkRU [src] [dst]--    GADD   _ s1 s2 dst  -> mkRU [s1,s2] [dst]-    GSUB   _ s1 s2 dst  -> mkRU [s1,s2] [dst]-    GMUL   _ s1 s2 dst  -> mkRU [s1,s2] [dst]-    GDIV   _ s1 s2 dst  -> mkRU [s1,s2] [dst]--    GCMP   _ src1 src2   -> mkRUR [src1,src2]-    GABS   _ src dst     -> mkRU [src] [dst]-    GNEG   _ src dst     -> mkRU [src] [dst]-    GSQRT  _ src dst     -> mkRU [src] [dst]-    GSIN   _ _ _ src dst -> mkRU [src] [dst]-    GCOS   _ _ _ src dst -> mkRU [src] [dst]-    GTAN   _ _ _ src dst -> mkRU [src] [dst]+    X87Store    _  dst    -> mkRUR ( use_EA dst [])      CVTSS2SD   src dst  -> mkRU [src] [dst]     CVTSD2SS   src dst  -> mkRU [src] [dst]@@ -603,33 +545,8 @@     JMP op regs          -> JMP (patchOp op) regs     JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl -    GMOV src dst         -> GMOV (env src) (env dst)-    GLD  fmt src dst     -> GLD fmt (lookupAddr src) (env dst)-    GST  fmt src dst     -> GST fmt (env src) (lookupAddr dst)--    GLDZ dst            -> GLDZ (env dst)-    GLD1 dst            -> GLD1 (env dst)--    GFTOI src dst       -> GFTOI (env src) (env dst)-    GDTOI src dst       -> GDTOI (env src) (env dst)--    GITOF src dst       -> GITOF (env src) (env dst)-    GITOD src dst       -> GITOD (env src) (env dst)--    GDTOF src dst       -> GDTOF (env src) (env dst)--    GADD fmt s1 s2 dst   -> GADD fmt (env s1) (env s2) (env dst)-    GSUB fmt s1 s2 dst   -> GSUB fmt (env s1) (env s2) (env dst)-    GMUL fmt s1 s2 dst   -> GMUL fmt (env s1) (env s2) (env dst)-    GDIV fmt s1 s2 dst   -> GDIV fmt (env s1) (env s2) (env dst)--    GCMP fmt src1 src2   -> GCMP fmt (env src1) (env src2)-    GABS fmt src dst     -> GABS fmt (env src) (env dst)-    GNEG fmt src dst     -> GNEG fmt (env src) (env dst)-    GSQRT fmt src dst    -> GSQRT fmt (env src) (env dst)-    GSIN fmt l1 l2 src dst       -> GSIN fmt l1 l2 (env src) (env dst)-    GCOS fmt l1 l2 src dst       -> GCOS fmt l1 l2 (env src) (env dst)-    GTAN fmt l1 l2 src dst       -> GTAN fmt l1 l2 (env src) (env dst)+    -- literally only support storing the top x87 stack value st(0)+    X87Store  fmt  dst     -> X87Store fmt  (lookupAddr dst)      CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)     CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)@@ -752,8 +669,7 @@     case targetClassOfReg platform reg of            RcInteger   -> MOV (archWordFormat is32Bit)                               (OpReg reg) (OpAddr (spRel dflags off))-           RcDouble    -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -}-           RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))+           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))            _         -> panic "X86.mkSpillInstr: no match"     where platform = targetPlatform dflags           is32Bit = target32Bit platform@@ -772,8 +688,7 @@         case targetClassOfReg platform reg of               RcInteger -> MOV (archWordFormat is32Bit)                                (OpAddr (spRel dflags off)) (OpReg reg)-              RcDouble  -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -}-              RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)+              RcDouble  -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)               _           -> panic "X86.x86_mkLoadInstr"     where platform = targetPlatform dflags           is32Bit = target32Bit platform@@ -827,6 +742,7 @@   +---  TODO: why is there -- | Make a reg-reg move instruction. --      On SPARC v8 there are no instructions to move directly between --      floating point and integer regs. If we need to do that then we@@ -844,8 +760,10 @@                      ArchX86    -> MOV II32 (OpReg src) (OpReg dst)                      ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)                      _          -> panic "x86_mkRegRegMoveInstr: Bad arch"-        RcDouble    -> GMOV src dst-        RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst)+        RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)+        -- this code is the lie we tell ourselves because both float and double+        -- use the same register class.on x86_64 and x86 32bit with SSE2,+        -- more plainly, both use the XMM registers         _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"  -- | Check whether an instruction represents a reg-reg move.@@ -969,58 +887,6 @@       ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]       ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]       _ -> panic "x86_mkStackDeallocInstr"--i386_insert_ffrees-        :: [GenBasicBlock Instr]-        -> [GenBasicBlock Instr]--i386_insert_ffrees blocks-   | any (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ]-   = map insertGFREEs blocks-   | otherwise-   = blocks- where-   insertGFREEs (BasicBlock id insns)-     = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns)--insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]-insertBeforeNonlocalTransfers insert insns-     = foldr p [] insns-     where p insn r = case insn of-                        CALL _ _    -> insert : insn : r-                        JMP _ _     -> insert : insn : r-                        JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"-                        _           -> insn : r----- if you ever add a new FP insn to the fake x86 FP insn set,--- you must update this too-is_G_instr :: Instr -> Bool-is_G_instr instr-   = case instr of-        GMOV{}          -> True-        GLD{}           -> True-        GST{}           -> True-        GLDZ{}          -> True-        GLD1{}          -> True-        GFTOI{}         -> True-        GDTOI{}         -> True-        GITOF{}         -> True-        GITOD{}         -> True-        GDTOF{}         -> True-        GADD{}          -> True-        GDIV{}          -> True-        GSUB{}          -> True-        GMUL{}          -> True-        GCMP{}          -> True-        GABS{}          -> True-        GNEG{}          -> True-        GSQRT{}         -> True-        GSIN{}          -> True-        GCOS{}          -> True-        GTAN{}          -> True-        GFREE           -> panic "is_G_instr: GFREE (!)"-        _               -> False   --

@@ -36,7 +36,7 @@  import Hoopl.Collections import Hoopl.Label-import BasicTypes       (Alignment)+import BasicTypes       (Alignment, mkAlignment, alignmentBytes) import DynFlags import Cmm              hiding (topInfoTable) import BlockId@@ -72,7 +72,7 @@  pprProcAlignment :: SDoc pprProcAlignment = sdocWithDynFlags $ \dflags ->-  (maybe empty pprAlign . cmmProcAlignment $ dflags)+  (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags))  pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) =@@ -145,7 +145,19 @@       (l@LOCATION{} : _) -> pprInstr l       _other             -> empty + pprDatas :: (Alignment, CmmStatics) -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+ pprDatas (align, (Statics lbl dats))  = vcat (pprAlign align : pprLabel lbl : map pprData dats) @@ -236,14 +248,15 @@             $$ pprTypeDecl lbl             $$ (ppr lbl <> char ':') -pprAlign :: Int -> SDoc-pprAlign bytes+pprAlign :: Alignment -> SDoc+pprAlign alignment         = sdocWithPlatform $ \platform ->-          text ".align " <> int (alignment platform)+          text ".align " <> int (alignmentOn platform)   where-        alignment platform = if platformOS platform == OSDarwin-                             then log2 bytes-                             else      bytes+        bytes = alignmentBytes alignment+        alignmentOn platform = if platformOS platform == OSDarwin+                               then log2 bytes+                               else      bytes          log2 :: Int -> Int  -- cache the common ones         log2 1 = 0@@ -271,7 +284,7 @@       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u       RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u+   where     ppr32_reg_no :: Format -> Int -> SDoc     ppr32_reg_no II8   = ppr32_reg_byte@@ -363,17 +376,14 @@  ppr_reg_float :: Int -> PtrString ppr_reg_float i = case i of-        16 -> sLit "%fake0";  17 -> sLit "%fake1"-        18 -> sLit "%fake2";  19 -> sLit "%fake3"-        20 -> sLit "%fake4";  21 -> sLit "%fake5"-        24 -> sLit "%xmm0";   25 -> sLit "%xmm1"-        26 -> sLit "%xmm2";   27 -> sLit "%xmm3"-        28 -> sLit "%xmm4";   29 -> sLit "%xmm5"-        30 -> sLit "%xmm6";   31 -> sLit "%xmm7"-        32 -> sLit "%xmm8";   33 -> sLit "%xmm9"-        34 -> sLit "%xmm10";  35 -> sLit "%xmm11"-        36 -> sLit "%xmm12";  37 -> sLit "%xmm13"-        38 -> sLit "%xmm14";  39 -> sLit "%xmm15"+        16 -> sLit "%xmm0" ;   17 -> sLit "%xmm1"+        18 -> sLit "%xmm2" ;   19 -> sLit "%xmm3"+        20 -> sLit "%xmm4" ;   21 -> sLit "%xmm5"+        22 -> sLit "%xmm6" ;   23 -> sLit "%xmm7"+        24 -> sLit "%xmm8" ;   25 -> sLit "%xmm9"+        26 -> sLit "%xmm10";   27 -> sLit "%xmm11"+        28 -> sLit "%xmm12";   29 -> sLit "%xmm13"+        30 -> sLit "%xmm14";   31 -> sLit "%xmm15"         _  -> sLit "very naughty x86 register"  pprFormat :: Format -> SDoc@@ -385,7 +395,6 @@                 II64  -> sLit "q"                 FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)                 FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)-                FF80  -> sLit "t"                 )  pprFormat_x87 :: Format -> SDoc@@ -393,9 +402,9 @@   = ptext $ case x of                 FF32  -> sLit "s"                 FF64  -> sLit "l"-                FF80  -> sLit "t"                 _     -> panic "X86.Ppr.pprFormat_x87" + pprCond :: Cond -> SDoc pprCond c  = ptext (case c of {@@ -806,225 +815,13 @@           ]  --- -------------------------------------------------------------------------------- i386 floating-point---- Simulating a flat register set on the x86 FP stack is tricky.--- you have to free %st(7) before pushing anything on the FP reg stack--- so as to preclude the possibility of a FP stack overflow exception.-pprInstr g@(GMOV src dst)-   | src == dst-   = empty-   | otherwise-   = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])---- GLD fmt addr dst ==> FLDsz addr ; FSTP (dst+1)-pprInstr g@(GLD fmt addr dst)- = pprG g (hcat [gtab, text "fld", pprFormat_x87 fmt, gsp,-                 pprAddr addr, gsemi, gpop dst 1])-+-- the -- GST fmt src addr ==> FLD dst ; FSTPsz addr-pprInstr g@(GST fmt src addr)- | src == fake0 && fmt /= FF80 -- fstt instruction doesn't exist- = pprG g (hcat [gtab,-                 text "fst", pprFormat_x87 fmt, gsp, pprAddr addr])- | otherwise- = pprG g (hcat [gtab, gpush src 0, gsemi,+pprInstr g@(X87Store fmt  addr)+ = pprX87 g (hcat [gtab,                  text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr]) -pprInstr g@(GLDZ dst)- = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])-pprInstr g@(GLD1 dst)- = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) -pprInstr (GFTOI src dst)-   = pprInstr (GDTOI src dst)--pprInstr g@(GDTOI src dst)-   = pprG g (vcat [-         hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],-         hcat [gtab, gpush src 0],-         hcat [gtab, text "movzwl 4(%esp), ", reg,-                     text " ; orl $0xC00, ", reg],-         hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],-         hcat [gtab, text "fistpl 0(%esp)"],-         hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],-         hcat [gtab, text "addl $8, %esp"]-     ])-   where-     reg = pprReg II32 dst--pprInstr (GITOF src dst)-   = pprInstr (GITOD src dst)--pprInstr g@(GITOD src dst)-   = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,-                   text " ; fildl (%esp) ; ",-                   gpop dst 1, text " ; addl $4,%esp"])--pprInstr g@(GDTOF src dst)-  = pprG g (vcat [gtab <> gpush src 0,-                  gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",-                  gtab <> gpop dst 1])--{- Gruesome swamp follows.  If you're unfortunate enough to have ventured-   this far into the jungle AND you give a Rat's Ass (tm) what's going-   on, here's the deal.  Generate code to do a floating point comparison-   of src1 and src2, of kind cond, and set the Zero flag if true.--   The complications are to do with handling NaNs correctly.  We want the-   property that if either argument is NaN, then the result of the-   comparison is False ... except if we're comparing for inequality,-   in which case the answer is True.--   Here's how the general (non-inequality) case works.  As an-   example, consider generating the an equality test:--     pushl %eax         -- we need to mess with this-     <get src1 to top of FPU stack>-     fcomp <src2 location in FPU stack> and pop pushed src1-                -- Result of comparison is in FPU Status Register bits-                -- C3 C2 and C0-     fstsw %ax  -- Move FPU Status Reg to %ax-     sahf       -- move C3 C2 C0 from %ax to integer flag reg-     -- now the serious magic begins-     setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0-     sete  %al     -- %al = if arg1 == arg2 then 1 else 0-     andb %ah,%al  -- %al &= %ah-                   -- so %al == 1 iff (comparable && same); else it holds 0-     decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);-                      else %al == 0xFF, ZeroFlag=0-     -- the zero flag is now set as we desire.-     popl %eax--   The special case of inequality differs thusly:--     setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0-     setne %al     -- %al = if arg1 /= arg2 then 1 else 0-     orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0-     decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)-                                                     else (%al == 0xFF, ZF=0)--}-pprInstr g@(GCMP cond src1 src2)-   | case cond of { NE -> True; _ -> False }-   = pprG g (vcat [-        hcat [gtab, text "pushl %eax ; ",gpush src1 0],-        hcat [gtab, text "fcomp ", greg src2 1,-                    text "; fstsw %ax ; sahf ;  setpe %ah"],-        hcat [gtab, text "setne %al ;  ",-              text "orb %ah,%al ;  decb %al ;  popl %eax"]-    ])-   | otherwise-   = pprG g (vcat [-        hcat [gtab, text "pushl %eax ; ",gpush src1 0],-        hcat [gtab, text "fcomp ", greg src2 1,-                    text "; fstsw %ax ; sahf ;  setpo %ah"],-        hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",-              text "andb %ah,%al ;  decb %al ;  popl %eax"]-    ])-    where-        {- On the 486, the flags set by FP compare are the unsigned ones!-           (This looks like a HACK to me.  WDP 96/03)-        -}-        fix_FP_cond :: Cond -> Cond-        fix_FP_cond GE   = GEU-        fix_FP_cond GTT  = GU-        fix_FP_cond LTT  = LU-        fix_FP_cond LE   = LEU-        fix_FP_cond EQQ  = EQQ-        fix_FP_cond NE   = NE-        fix_FP_cond _    = panic "X86.Ppr.fix_FP_cond: no match"-        -- there should be no others---pprInstr g@(GABS _ src dst)-   = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])--pprInstr g@(GNEG _ src dst)-   = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])--pprInstr g@(GSQRT fmt src dst)-   = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$-             hcat [gtab, gcoerceto fmt, gpop dst 1])--pprInstr g@(GSIN fmt l1 l2 src dst)-   = pprG g (pprTrigOp "fsin" False l1 l2 src dst fmt)--pprInstr g@(GCOS fmt l1 l2 src dst)-   = pprG g (pprTrigOp "fcos" False l1 l2 src dst fmt)--pprInstr g@(GTAN fmt l1 l2 src dst)-   = pprG g (pprTrigOp "fptan" True l1 l2 src dst fmt)---- In the translations for GADD, GMUL, GSUB and GDIV,--- the first two cases are mere optimisations.  The otherwise clause--- generates correct code under all circumstances.--pprInstr g@(GADD _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GADD-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; faddp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GADD-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; faddp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-                   text " ; fadd ", greg src2 1, text ",%st(0)",-                   gsemi, gpop dst 1])---pprInstr g@(GMUL _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GMUL-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; fmulp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GMUL-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; fmulp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-             text " ; fmul ", greg src2 1, text ",%st(0)",-             gsemi, gpop dst 1])---pprInstr g@(GSUB _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GSUB-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; fsubrp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GSUB-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; fsubp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-                   text " ; fsub ", greg src2 1, text ",%st(0)",-                   gsemi, gpop dst 1])---pprInstr g@(GDIV _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GDIV-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; fdivrp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GDIV-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; fdivp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-                   text " ; fdiv ", greg src2 1, text ",%st(0)",-                   gsemi, gpop dst 1])---pprInstr GFREE-   = vcat [ text "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)",-            text "\tffree %st(4) ;ffree %st(5)"-          ]- -- Atomics  pprInstr (LOCK i) = text "\tlock" $$ pprInstr i@@ -1037,116 +834,27 @@    = pprFormatOpOp (sLit "cmpxchg") format src dst  -pprTrigOp :: String -> Bool -> CLabel -> CLabel-          -> Reg -> Reg -> Format -> SDoc-pprTrigOp op -- fsin, fcos or fptan-          isTan -- we need a couple of extra steps if we're doing tan-          l1 l2 -- internal labels for us to use-          src dst fmt-    = -- We'll be needing %eax later on-      hcat [gtab, text "pushl %eax;"] $$-      -- tan is going to use an extra space on the FP stack-      (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$-      -- First put the value in %st(0) and try to apply the op to it-      hcat [gpush src 0, text ("; " ++ op)] $$-      -- Now look to see if C2 was set (overflow, |value| >= 2^63)-      hcat [gtab, text "fnstsw %ax"] $$-      hcat [gtab, text "test   $0x400,%eax"] $$-      -- If we were in bounds then jump to the end-      hcat [gtab, text "je     " <> ppr l1] $$-      -- Otherwise we need to shrink the value. Start by-      -- loading pi, doubleing it (by adding it to itself),-      -- and then swapping pi with the value, so the value we-      -- want to apply op to is in %st(0) again-      hcat [gtab, text "ffree %st(7); fldpi"] $$-      hcat [gtab, text "fadd   %st(0),%st"] $$-      hcat [gtab, text "fxch   %st(1)"] $$-      -- Now we have a loop in which we make the value smaller,-      -- see if it's small enough, and loop if not-      (ppr l2 <> char ':') $$-      hcat [gtab, text "fprem1"] $$-      -- My Debian libc uses fstsw here for the tan code, but I can't-      -- see any reason why it should need to be different for tan.-      hcat [gtab, text "fnstsw %ax"] $$-      hcat [gtab, text "test   $0x400,%eax"] $$-      hcat [gtab, text "jne    " <> ppr l2] $$-      hcat [gtab, text "fstp   %st(1)"] $$-      hcat [gtab, text op] $$-      (ppr l1 <> char ':') $$-      -- Pop the 1.0 tan gave us-      (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$-      -- Restore %eax-      hcat [gtab, text "popl %eax;"] $$-      -- And finally make the result the right size-      hcat [gtab, gcoerceto fmt, gpop dst 1]  --------------------------+-- some left over --- coerce %st(0) to the specified size-gcoerceto :: Format -> SDoc-gcoerceto FF64 = empty-gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "-gcoerceto _    = panic "X86.Ppr.gcoerceto: no match" -gpush :: Reg -> RegNo -> SDoc-gpush reg offset-   = hcat [text "fld ", greg reg offset] -gpop :: Reg -> RegNo -> SDoc-gpop reg offset-   = hcat [text "fstp ", greg reg offset]--greg :: Reg -> RegNo -> SDoc-greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'--gsemi :: SDoc-gsemi = text " ; "- gtab :: SDoc gtab  = char '\t'  gsp :: SDoc gsp   = char ' ' -gregno :: Reg -> RegNo-gregno (RegReal (RealRegSingle i)) = i-gregno _           = --pprPanic "gregno" (ppr other)-                     999   -- bogus; only needed for debug printing -pprG :: Instr -> SDoc -> SDoc-pprG fake actual-   = (char '#' <> pprGInstr fake) $$ actual --pprGInstr :: Instr -> SDoc-pprGInstr (GMOV src dst)   = pprFormatRegReg (sLit "gmov") FF64 src dst-pprGInstr (GLD fmt src dst) = pprFormatAddrReg (sLit "gld") fmt src dst-pprGInstr (GST fmt src dst) = pprFormatRegAddr (sLit "gst") fmt src dst--pprGInstr (GLDZ dst) = pprFormatReg (sLit "gldz") FF64 dst-pprGInstr (GLD1 dst) = pprFormatReg (sLit "gld1") FF64 dst--pprGInstr (GFTOI src dst) = pprFormatFormatRegReg (sLit "gftoi") FF32 II32 src dst-pprGInstr (GDTOI src dst) = pprFormatFormatRegReg (sLit "gdtoi") FF64 II32 src dst--pprGInstr (GITOF src dst) = pprFormatFormatRegReg (sLit "gitof") II32 FF32 src dst-pprGInstr (GITOD src dst) = pprFormatFormatRegReg (sLit "gitod") II32 FF64 src dst-pprGInstr (GDTOF src dst) = pprFormatFormatRegReg (sLit "gdtof") FF64 FF32 src dst--pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst-pprGInstr (GABS fmt src dst) = pprFormatRegReg (sLit "gabs") fmt src dst-pprGInstr (GNEG fmt src dst) = pprFormatRegReg (sLit "gneg") fmt src dst-pprGInstr (GSQRT fmt src dst) = pprFormatRegReg (sLit "gsqrt") fmt src dst-pprGInstr (GSIN fmt _ _ src dst) = pprFormatRegReg (sLit "gsin") fmt src dst-pprGInstr (GCOS fmt _ _ src dst) = pprFormatRegReg (sLit "gcos") fmt src dst-pprGInstr (GTAN fmt _ _ src dst) = pprFormatRegReg (sLit "gtan") fmt src dst--pprGInstr (GADD fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gadd") fmt src1 src2 dst-pprGInstr (GSUB fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gsub") fmt src1 src2 dst-pprGInstr (GMUL fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gmul") fmt src1 src2 dst-pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 src2 dst+pprX87 :: Instr -> SDoc -> SDoc+pprX87 fake actual+   = (char '#' <> pprX87Instr fake) $$ actual -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"+pprX87Instr :: Instr -> SDoc+pprX87Instr (X87Store fmt  dst) = pprFormatAddr (sLit "gst") fmt  dst+pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"  pprDollImm :: Imm -> SDoc pprDollImm i = text "$" <> pprImm i@@ -1214,24 +922,7 @@     ]  -pprFormatReg :: PtrString -> Format -> Reg -> SDoc-pprFormatReg name format reg1-  = hcat [-        pprMnemonic name format,-        pprReg format reg1-    ] --pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc-pprFormatRegReg name format reg1 reg2-  = hcat [-        pprMnemonic name format,-        pprReg format reg1,-        comma,-        pprReg format reg2-    ]-- pprRegReg :: PtrString -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2   = sdocWithPlatform $ \platform ->@@ -1265,31 +956,6 @@         pprReg format reg2     ] -pprCondRegReg :: PtrString -> Format -> Cond -> Reg -> Reg -> SDoc-pprCondRegReg name format cond reg1 reg2-  = hcat [-        char '\t',-        ptext name,-        pprCond cond,-        space,-        pprReg format reg1,-        comma,-        pprReg format reg2-    ]--pprFormatFormatRegReg :: PtrString -> Format -> Format -> Reg -> Reg -> SDoc-pprFormatFormatRegReg name format1 format2 reg1 reg2-  = hcat [-        char '\t',-        ptext name,-        pprFormat format1,-        pprFormat format2,-        space,-        pprReg format1 reg1,-        comma,-        pprReg format2 reg2-    ]- pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc pprFormatFormatOpReg name format1 format2 op1 reg2   = hcat [@@ -1299,17 +965,6 @@         pprReg format2 reg2     ] -pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc-pprFormatRegRegReg name format reg1 reg2 reg3-  = hcat [-        pprMnemonic name format,-        pprReg format reg1,-        comma,-        pprReg format reg2,-        comma,-        pprReg format reg3-    ]- pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc pprFormatOpOpReg name format op1 op2 reg3   = hcat [@@ -1321,25 +976,15 @@         pprReg format reg3     ] -pprFormatAddrReg :: PtrString -> Format -> AddrMode -> Reg -> SDoc-pprFormatAddrReg name format op dst-  = hcat [-        pprMnemonic name format,-        pprAddr op,-        comma,-        pprReg format dst-    ]  -pprFormatRegAddr :: PtrString -> Format -> Reg -> AddrMode -> SDoc-pprFormatRegAddr name format src op+pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc+pprFormatAddr name format  op   = hcat [         pprMnemonic name format,-        pprReg format src,         comma,         pprAddr op     ]-  pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc pprShift name format src dest

@@ -25,10 +25,13 @@ mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format    = case format of-        FF32    -> VirtualRegSSE u-        FF64    -> VirtualRegSSE u-        FF80    -> VirtualRegD   u-        _other  -> VirtualRegI   u+        FF32    -> VirtualRegD u+        -- for scalar F32, we use the same xmm as F64!+        -- this is a hack that needs some improvement.+        -- For now we map both to being allocated as "Double" Registers+        -- on X86/X86_64+        FF64    -> VirtualRegD u+        _other  -> VirtualRegI u  regDotColor :: Platform -> RealReg -> SDoc regDotColor platform reg@@ -37,11 +40,12 @@         _        -> panic "Register not assigned a color"  regColors :: Platform -> UniqFM [Char]-regColors platform = listToUFM (normalRegColors platform ++ fpRegColors platform)+regColors platform = listToUFM (normalRegColors platform)  normalRegColors :: Platform -> [(Reg,String)] normalRegColors platform =     zip (map regSingle [0..lastint platform]) colors+        ++ zip (map regSingle [firstxmm..lastxmm platform]) greys   where     -- 16 colors - enough for amd64 gp regs     colors = ["#800000","#ff0000","#808000","#ffff00","#008000"@@ -49,17 +53,6 @@              ,"#800080","#ff00ff","#87005f","#875f00","#87af00"              ,"#ff00af"] -fpRegColors :: Platform -> [(Reg,String)]-fpRegColors platform =-        [ (fake0, "red")-        , (fake1, "red")-        , (fake2, "red")-        , (fake3, "red")-        , (fake4, "red")-        , (fake5, "red") ]--        ++ zip (map regSingle [firstxmm..lastxmm platform]) greys-  where     -- 16 shades of grey, enough for the currently supported     -- SSE extensions.     greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646"

@@ -29,8 +29,8 @@         EABase(..), EAIndex(..), addrModeRegs,          eax, ebx, ecx, edx, esi, edi, ebp, esp,-        fake0, fake1, fake2, fake3, fake4, fake5, firstfake, +         rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,         r8,  r9,  r10, r11, r12, r13, r14, r15,         lastint,@@ -86,10 +86,6 @@                 VirtualRegF{}           -> 0                 _other                  -> 0 -        RcDoubleSSE-         -> case vr of-                VirtualRegSSE{}         -> 1-                _other                  -> 0          _other -> 0 @@ -100,7 +96,7 @@         RcInteger          -> case rr of                 RealRegSingle regNo-                        | regNo < firstfake -> 1+                        | regNo < firstxmm -> 1                         | otherwise     -> 0                  RealRegPair{}           -> 0@@ -108,15 +104,11 @@         RcDouble          -> case rr of                 RealRegSingle regNo-                        | regNo >= firstfake && regNo <= lastfake -> 1+                        | regNo >= firstxmm  -> 1                         | otherwise     -> 0                  RealRegPair{}           -> 0 -        RcDoubleSSE-         -> case rr of-                RealRegSingle regNo | regNo >= firstxmm -> 1-                _otherwise                        -> 0          _other -> 0 @@ -210,17 +202,16 @@ -- use a Word32 to represent the set of free registers in the register -- allocator. -firstfake, lastfake :: RegNo-firstfake = 16-lastfake  = 21 + firstxmm :: RegNo-firstxmm  = 24+firstxmm  = 16 +--  on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available lastxmm :: Platform -> RegNo lastxmm platform- | target32Bit platform = 31- | otherwise            = 39+ | target32Bit platform = firstxmm + 7  -- xmm0 - xmmm7+ | otherwise            = firstxmm + 15 -- xmm0 -xmm15  lastint :: Platform -> RegNo lastint platform@@ -230,14 +221,13 @@ intregnos :: Platform -> [RegNo] intregnos platform = [0 .. lastint platform] -fakeregnos :: [RegNo]-fakeregnos  = [firstfake .. lastfake] + xmmregnos :: Platform -> [RegNo] xmmregnos platform = [firstxmm  .. lastxmm platform]  floatregnos :: Platform -> [RegNo]-floatregnos platform = fakeregnos ++ xmmregnos platform+floatregnos platform = xmmregnos platform  -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty.@@ -257,20 +247,19 @@ -- However, we can get away without this at the moment because the -- only allocatable integer regs are also 8-bit compatible (1, 3, 4). classOfRealReg platform reg- = case reg of+    = case reg of         RealRegSingle i-          | i <= lastint platform -> RcInteger-          | i <= lastfake         -> RcDouble-          | otherwise             -> RcDoubleSSE--        RealRegPair{}   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"+            | i <= lastint platform -> RcInteger+            | i <= lastxmm platform -> RcDouble+            | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"+        _   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"  -- | Get the name of the register with this number.+-- NOTE: fixme, we dont track which "way" the XMM registers are used showReg :: Platform -> RegNo -> String showReg platform n-        | n >= firstxmm  = "%xmm" ++ show (n-firstxmm)-        | n >= firstfake = "%fake" ++ show (n-firstfake)-        | n >= 8         = "%r" ++ show n+        | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)+        | n >= 8   && n < firstxmm      = "%r" ++ show n         | otherwise      = regNames platform A.! n  regNames :: Platform -> A.Array Int String@@ -290,18 +279,17 @@ - Only ebx, esi, edi and esp are available across a C call (they are callee-saves). - Registers 0-7 have 16-bit counterparts (ax, bx etc.) - Registers 0-3 have 8 bit counterparts (ah, bh etc.)-- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable-  fp registers, and 3-operand insns for them, and we translate this into-  real stack-based x86 fp code after register allocation.  The fp registers are all Double registers; we don't have any RcFloat class regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should never generate them.++TODO: cleanup modelling float vs double registers and how they are the same class. -} -fake0, fake1, fake2, fake3, fake4, fake5,-       eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg +eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg+ eax   = regSingle 0 ebx   = regSingle 1 ecx   = regSingle 2@@ -310,15 +298,10 @@ edi   = regSingle 5 ebp   = regSingle 6 esp   = regSingle 7-fake0 = regSingle 16-fake1 = regSingle 17-fake2 = regSingle 18-fake3 = regSingle 19-fake4 = regSingle 20-fake5 = regSingle 21   + {- AMD x86_64 architecture: - All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:@@ -362,22 +345,22 @@ r13   = regSingle 13 r14   = regSingle 14 r15   = regSingle 15-xmm0  = regSingle 24-xmm1  = regSingle 25-xmm2  = regSingle 26-xmm3  = regSingle 27-xmm4  = regSingle 28-xmm5  = regSingle 29-xmm6  = regSingle 30-xmm7  = regSingle 31-xmm8  = regSingle 32-xmm9  = regSingle 33-xmm10 = regSingle 34-xmm11 = regSingle 35-xmm12 = regSingle 36-xmm13 = regSingle 37-xmm14 = regSingle 38-xmm15 = regSingle 39+xmm0  = regSingle 16+xmm1  = regSingle 17+xmm2  = regSingle 18+xmm3  = regSingle 19+xmm4  = regSingle 20+xmm5  = regSingle 21+xmm6  = regSingle 22+xmm7  = regSingle 23+xmm8  = regSingle 24+xmm9  = regSingle 25+xmm10 = regSingle 26+xmm11 = regSingle 27+xmm12 = regSingle 28+xmm13 = regSingle 29+xmm14 = regSingle 30+xmm15 = regSingle 31  ripRel :: Displacement -> AddrMode ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm@@ -411,7 +394,7 @@    -- Only xmm0-5 are caller-saves registers on 64bit windows.    -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )    -- For details check the Win64 ABI.-   ++ map regSingle fakeregnos ++ map xmm [0  .. 5]+   ++ map xmm [0  .. 5]  | otherwise     -- all xmm regs are caller-saves     -- caller-saves registers@@ -430,11 +413,15 @@     = panic "X86.Regs.allIntArgRegs: not defined for this platform"  | otherwise = [rdi,rsi,rdx,rcx,r8,r9] ++-- | on 64bit platforms we pass the first 8 float/double arguments+-- in the xmm registers. allFPArgRegs :: Platform -> [Reg] allFPArgRegs platform  | platformOS platform == OSMinGW32     = panic "X86.Regs.allFPArgRegs: not defined for this platform"- | otherwise = map regSingle [firstxmm .. firstxmm+7]+ | otherwise = map regSingle [firstxmm .. firstxmm + 7 ]+  -- Machine registers which might be clobbered by instructions that -- generate results into fixed registers, or need arguments in a fixed

@@ -27,7 +27,7 @@ -- Should stay in sync with the import list of DsMeta  templateHaskellNames = [-    returnQName, bindQName, sequenceQName, newNameName, liftName,+    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,     mkNameSName,     liftStringName,@@ -206,7 +206,7 @@ returnQName, bindQName, sequenceQName, newNameName, liftName,     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,     mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,-    unsafeTExpCoerceName :: Name+    unsafeTExpCoerceName, liftTypedName :: Name returnQName    = thFun (fsLit "returnQ")   returnQIdKey bindQName      = thFun (fsLit "bindQ")     bindQIdKey sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey@@ -222,6 +222,7 @@ unTypeName     = thFun (fsLit "unType")     unTypeIdKey unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey+liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey   -------------------- TH.Lib -----------------------@@ -726,7 +727,7 @@ returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,     mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,-    unsafeTExpCoerceIdKey :: Unique+    unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique returnQIdKey        = mkPreludeMiscIdUnique 200 bindQIdKey          = mkPreludeMiscIdUnique 201 sequenceQIdKey      = mkPreludeMiscIdUnique 202@@ -741,6 +742,7 @@ unTypeIdKey          = mkPreludeMiscIdUnique 211 unTypeQIdKey         = mkPreludeMiscIdUnique 212 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213+liftTypedIdKey        = mkPreludeMiscIdUnique 214   -- data Lit = ...@@ -1078,8 +1080,9 @@ ************************************************************************ -} -lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName lift_RDR     = nameRdrName liftName+liftTyped_RDR = nameRdrName liftTypedName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName 

@@ -245,8 +245,8 @@     new_id = uniqAway (ce_in_scope env) old_id     no_change = new_id == old_id     env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }-    new_env | no_change = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }-            | otherwise = env'+    new_env | no_change = env'+            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }  substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar]) substBndrs env bndrs = mapAccumL substBndr env bndrs

@@ -730,28 +730,35 @@         ; return (rules2 ++ rules1, final_binds) } -  |  warnMissingSpecs dflags callers-  = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))-                            2 (vcat [ text "when specialising" <+> quotes (ppr caller)-                                    | caller <- callers])-                      , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))-                      , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])-       ; return ([], []) }+  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn+                   ; return ([], [])} -  | otherwise-  = return ([], [])   where     unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers -warnMissingSpecs :: DynFlags -> [Id] -> Bool+-- | Returns whether or not to show a missed-spec warning.+-- If -Wall-missed-specializations is on, show the warning.+-- Otherwise, if -Wmissed-specializations is on, only show a warning+-- if there is at least one imported function being specialized,+-- and if all imported functions are marked with an inline pragma+-- Use the most specific warning as the reason.+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations]-warnMissingSpecs dflags callers-  | wopt Opt_WarnAllMissedSpecs dflags = True-  | not (wopt Opt_WarnMissedSpecs dflags) = False-  | null callers                       = False-  | otherwise                          = all has_inline_prag callers+tryWarnMissingSpecs dflags callers fn calls_for_fn+  | wopt Opt_WarnMissedSpecs dflags+    && not (null callers)+    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+  | otherwise                             = return ()   where-    has_inline_prag id = isAnyInlinePragma (idInlinePragma id)+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers+    doWarn reason = +      warnMsg reason+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)+                        | caller <- callers])+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])  wantSpecImport :: DynFlags -> Unfolding -> Bool -- See Note [Specialise imported INLINABLE things]

@@ -831,18 +831,31 @@     else sep [ ppr tickish, pprStgExpr expr ]  +-- Don't indent for a single case alternative.+pprStgExpr (StgCase expr bndr alt_type [alt])+  = sep [sep [text "case",+           nest 4 (hsep [pprStgExpr expr,+             whenPprDebug (dcolon <+> ppr alt_type)]),+           text "of", pprBndr CaseBind bndr, char '{'],+           pprStgAlt False alt,+           char '}']+ pprStgExpr (StgCase expr bndr alt_type alts)   = sep [sep [text "case",            nest 4 (hsep [pprStgExpr expr,              whenPprDebug (dcolon <+> ppr alt_type)]),            text "of", pprBndr CaseBind bndr, char '{'],-           nest 2 (vcat (map pprStgAlt alts)),+           nest 2 (vcat (map (pprStgAlt True) alts)),            char '}'] -pprStgAlt :: OutputablePass pass => GenStgAlt pass -> SDoc-pprStgAlt (con, params, expr)-  = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])-         4 (ppr expr <> semi)++pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc+pprStgAlt indent (con, params, expr)+  | indent    = hang altPattern 4 (ppr expr <> semi)+  | otherwise = sep [altPattern, ppr expr <> semi]+    where+      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])+  pprStgOp :: StgOp -> SDoc pprStgOp (StgPrimOp  op)   = ppr op

@@ -78,24 +78,30 @@ ************************************************************************ -} -newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)--- Used when Name is the wired-in name for a wired-in class method,+newMethodFromName+  :: CtOrigin              -- ^ why do we need this?+  -> Name                  -- ^ name of the method+  -> [TcRhoType]           -- ^ types with which to instantiate the class+  -> TcM (HsExpr GhcTcId)+-- ^ Used when 'Name' is the wired-in name for a wired-in class method, -- so the caller knows its type for sure, which should be of form---    forall a. C a => <blah>--- newMethodFromName is supposed to instantiate just the outer+--+-- > forall a. C a => <blah>+--+-- 'newMethodFromName' is supposed to instantiate just the outer -- type variable and constraint -newMethodFromName origin name inst_ty+newMethodFromName origin name ty_args   = do { id <- tcLookupId name               -- Use tcLookupId not tcLookupGlobalId; the method is almost               -- always a class op, but with -XRebindableSyntax GHC is               -- meant to find whatever thing is in scope, and that may               -- be an ordinary function. -       ; let ty = piResultTy (idType id) inst_ty+       ; let ty = piResultTys (idType id) ty_args              (theta, _caller_knows_this) = tcSplitPhiTy ty        ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )-                 instCall origin [inst_ty] theta+                 instCall origin ty_args theta         ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) } @@ -607,7 +613,7 @@  tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))   | std_nm == user_nm-  = do rhs <- newMethodFromName orig std_nm ty+  = do rhs <- newMethodFromName orig std_nm [ty]        return (std_nm, rhs)  tcSyntaxName orig ty (std_nm, user_nm_expr) = do

@@ -1015,7 +1015,7 @@             -- Done: unify phi1 ~ phi2             go [] subst bndrs2               = ASSERT( null bndrs2 )-                unify loc (eqRelRole eq_rel) phi1' (substTy subst phi2)+                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)              go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) [] 

@@ -335,6 +335,8 @@     -- (See Note [Newtype-deriving instances] in TcGenDeriv)     unsetXOptM LangExt.RebindableSyntax $     -- See Note [Avoid RebindableSyntax when deriving]+    setXOptM LangExt.TemplateHaskellQuotes $+    -- DeriveLift makes uses of quotes     do  {         -- Bring the extra deriving stuff into scope         -- before renaming the instances themselves

@@ -738,8 +738,10 @@                          (cond_isProduct `andCond` cond_args cls)  cond_args :: Class -> Condition--- For some classes (eg Eq, Ord) we allow unlifted arg types--- by generating specialised code.  For others (eg Data) we don't.+-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types+-- by generating specialised code.  For others (eg 'Data') we don't.+-- For even others (eg 'Lift'), unlifted types aren't even a special+-- consideration! cond_args cls _ _ rep_tc   = case bad_args of       []     -> IsValid@@ -748,7 +750,7 @@   where     bad_args = [ arg_ty | con <- tyConDataCons rep_tc                         , arg_ty <- dataConOrigArgTys con-                        , isUnliftedType arg_ty+                        , isLiftedType_maybe arg_ty /= Just True                         , not (ok_ty arg_ty) ]      cls_key = classKey cls@@ -756,7 +758,7 @@      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl      | cls_key == showClassKey = check_in arg_ty boxConTbl-     | cls_key == liftClassKey = check_in arg_ty litConTbl+     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic      | otherwise               = False    -- Read, Ix etc      check_in :: Type -> [(Type,a)] -> Bool

@@ -639,7 +639,8 @@         ; emitStaticConstraints lie          -- Wrap the static form with the 'fromStaticPtr' call.-        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName+                                             [p_ty]         ; let wrap = mkWpTyApps [expr_ty]         ; loc <- getSrcSpanM         ; return $ mkHsWrapCo co $ HsApp noExt@@ -1040,7 +1041,7 @@   = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty        ; expr' <- tcPolyExpr expr elt_ty        ; enum_from <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromName elt_ty+                              enumFromName [elt_ty]        ; return $ mkHsWrap wrap $          ArithSeq enum_from wit' (From expr') } @@ -1049,7 +1050,7 @@        ; expr1' <- tcPolyExpr expr1 elt_ty        ; expr2' <- tcPolyExpr expr2 elt_ty        ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromThenName elt_ty+                              enumFromThenName [elt_ty]        ; return $ mkHsWrap wrap $          ArithSeq enum_from_then wit' (FromThen expr1' expr2') } @@ -1058,7 +1059,7 @@        ; expr1' <- tcPolyExpr expr1 elt_ty        ; expr2' <- tcPolyExpr expr2 elt_ty        ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromToName elt_ty+                              enumFromToName [elt_ty]        ; return $ mkHsWrap wrap $          ArithSeq enum_from_to wit' (FromTo expr1' expr2') } @@ -1068,7 +1069,7 @@         ; expr2' <- tcPolyExpr expr2 elt_ty         ; expr3' <- tcPolyExpr expr3 elt_ty         ; eft <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromThenToName elt_ty+                              enumFromThenToName [elt_ty]         ; return $ mkHsWrap wrap $           ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } @@ -2041,7 +2042,8 @@                      setConstraintVar lie_var   $                           -- Put the 'lift' constraint into the right LIE                      newMethodFromName (OccurrenceOf id_name)-                                       THNames.liftName id_ty+                                       THNames.liftName+                                       [getRuntimeRep id_ty, id_ty]                     -- Update the pending splices         ; ps <- readMutVar ps_var

@@ -54,8 +54,6 @@ import FamInstEnv import PrelNames import THNames-import Module ( moduleName, moduleNameString-              , moduleUnitId, unitIdString ) import MkId ( coerceId ) import PrimOp import SrcLoc@@ -1559,68 +1557,36 @@     ==>      instance (Lift a) => Lift (Foo a) where-        lift (Foo a)-          = appE-              (conE-                (mkNameG_d "package-name" "ModuleName" "Foo"))-              (lift a)-        lift (u :^: v)-          = infixApp-              (lift u)-              (conE-                (mkNameG_d "package-name" "ModuleName" ":^:"))-              (lift v)+        lift (Foo a) = [| Foo a |]+        lift ((:^:) u v) = [| (:^:) u v |] -Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what-'Foo would be when using the -XTemplateHaskell extension. To make sure that--XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke-makeG_d.+        liftTyped (Foo a) = [|| Foo a ||]+        liftTyped ((:^:) u v) = [|| (:^:) u v ||] -} + gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)+gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)   where-    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)-                            (map pats_etc data_cons)+    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)+                                 (map (pats_etc mk_exp) data_cons)+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)+                                 (map (pats_etc mk_texp) data_cons)++    mk_exp = ExpBr NoExt+    mk_texp = TExpBr NoExt     data_cons = tyConDataCons tycon -    pats_etc data_con+    pats_etc mk_bracket data_con       = ([con_pat], lift_Expr)        where             con_pat      = nlConVarPat data_con_RDR as_needed             data_con_RDR = getRdrName data_con             con_arity    = dataConSourceArity data_con             as_needed    = take con_arity as_RDRs-            lifted_as    = zipWithEqual "mk_lift_app" mk_lift_app-                             tys_needed as_needed-            tycon_name   = tyConName tycon-            is_infix     = dataConIsInfix data_con-            tys_needed   = dataConOrigArgTys data_con--            mk_lift_app ty a-              | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)-                                                  (nlHsVar a)-              | otherwise = nlHsApp (nlHsVar litE_RDR)-                              (primLitOp (mkBoxExp (nlHsVar a)))-              where (primLitOp, mkBoxExp) = primLitOps "Lift" ty--            pkg_name = unitIdString . moduleUnitId-                     . nameModule $ tycon_name-            mod_name = moduleNameString . moduleName . nameModule $ tycon_name-            con_name = occNameString . nameOccName . dataConName $ data_con--            conE_Expr = nlHsApp (nlHsVar conE_RDR)-                                (nlHsApps mkNameG_dRDR-                                  (map (nlHsLit . mkHsString)-                                    [pkg_name, mod_name, con_name]))--            lift_Expr-              | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]-              | otherwise = foldl' mk_appE_app conE_Expr lifted_as-            (a1:a2:_) = lifted_as--mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-mk_appE_app a b = nlHsApps appE_RDR [a, b]+            lift_Expr    = noLoc (HsBracket NoExt (mk_bracket br_body))+            br_body      = nlHsApps (Exact (dataConName data_con))+                                    (map nlHsVar as_needed)  {- ************************************************************************@@ -2133,17 +2099,6 @@            -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt) -- See Note [Deriving and unboxed types] in TcDerivInfer primOrdOps str ty = assoc_ty_id str ordOpTbl ty--primLitOps :: String -- The class involved-           -> Type   -- The type-           -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value-              , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value-              )-primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)-  where-    boxed v-      | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v-      | otherwise = assoc_ty_id str boxConTbl ty v  ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] ordOpTbl

@@ -1496,7 +1496,7 @@                -> TcTyVar                -> Bool quantifiableTv outer_tclvl tcv-  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separtely+  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately   = tcTyVarLevel tcv > outer_tclvl   | otherwise   = False

@@ -515,7 +515,7 @@                              , sig_inst_skols = tv_prs                              , sig_inst_wcs   = wcs                              , sig_inst_wcx   = wcx-                             , sig_inst_theta = substTys subst theta+                             , sig_inst_theta = substTysUnchecked subst theta                              , sig_inst_tau   = substTyUnchecked  subst tau }        ; traceTc "End partial sig }" (ppr inst_sig)        ; return inst_sig }

@@ -177,13 +177,14 @@        ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $                                 tcInferRhoNC expr                                 -- NC for no context; tcBracket does that+       ; let rep = getRuntimeRep expr_ty         ; meta_ty <- tcTExpTy expr_ty        ; ps' <- readMutVar ps_ref        ; texpco <- tcLookupId unsafeTExpCoerceName        ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")                        rn_expr-                       (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])+                       (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])                                       (noLoc (HsTcBracketOut noExt brack ps'))))                        meta_ty res_ty } tcTypedBracket _ other_brack _@@ -230,7 +231,8 @@   = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)        ; q    <- tcLookupTyCon qTyConName        ; texp <- tcLookupTyCon tExpTyConName-       ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }+       ; let rep = getRuntimeRep exp_ty+       ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }   where     err_msg ty       = vcat [ text "Illegal polytype:" <+> ppr ty@@ -469,12 +471,13 @@     -- A splice inside brackets tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty   = do { res_ty <- expTypeToType res_ty+       ; let rep = getRuntimeRep res_ty        ; meta_exp_ty <- tcTExpTy res_ty        ; expr' <- setStage pop_stage $                   setConstraintVar lie_var $                   tcMonoExpr expr (mkCheckExpType meta_exp_ty)        ; untypeq <- tcLookupId unTypeQName-       ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'        ; ps <- readMutVar ps_var        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) 

@@ -1497,7 +1497,7 @@   = -- See Note [Type-checking default assoc decls]     setSrcSpan loc $     tcAddFamInstCtxt (text "default type instance") tc_name $-    do { traceTc "tcDefaultAssocDecl" (ppr tc_name)+    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)        ; let fam_tc_name = tyConName fam_tc              fam_arity = length (tyConVisibleTyVars fam_tc) @@ -1524,14 +1524,46 @@                                                     imp_vars exp_vars                                                     hs_pats hs_rhs_ty -         -- See Note [Type-checking default assoc decls]-       ; traceTc "tcDefault" (vcat [ppr (tyConTyVars fam_tc), ppr qtvs, ppr pats])-       ; case tcMatchTys pats (mkTyVarTys (tyConTyVars fam_tc)) of-           Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) )-           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)-           -- We check for well-formedness and validity later,-           -- in checkValidClass+       ; let fam_tvs = tyConTyVars fam_tc+       ; traceTc "tcDefaultAssocDecl 2" (vcat+           [ text "fam_tvs" <+> ppr fam_tvs+           , text "qtvs"    <+> ppr qtvs+           , text "pats"    <+> ppr pats+           , text "rhs_ty"  <+> ppr rhs_ty+           ])+       ; pat_tvs <- traverse (extract_tv pats rhs_ty) pats+       ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)+       ; pure $ Just (substTyUnchecked subst rhs_ty, loc)+           -- We also perform other checks for well-formedness and validity+           -- later, in checkValidClass      }+  where+    -- Checks that a pattern on the LHS of a default is a type+    -- variable. If so, return the underlying type variable, and if+    -- not, throw an error.+    -- See Note [Type-checking default assoc decls]+    extract_tv :: [Type] -- All default instance type patterns+                         -- (only used for error message purposes)+               -> Type   -- The default instance's right-hand side type+                         -- (only used for error message purposes)+               -> Type   -- The particular type pattern from which to extract+                         -- its underlying type variable+               -> TcM TyVar+    extract_tv pats rhs_ty pat =+      case getTyVar_maybe pat of+        Just tv -> pure tv+        Nothing ->+          -- Per Note [Type-checking default assoc decls], we already+          -- know by this point that if any arguments in the default+          -- instance aren't type variables, then they must be+          -- invisible kind arguments. Therefore, always display the+          -- error message with -fprint-explicit-kinds enabled.+          failWithTc $ pprWithExplicitKindsWhen True $+          hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")+             2 (vcat [ quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)+                       <+> equals <+> ppr rhs_ty)+                     , text "The arguments to" <+> quotes (ppr fam_tc)+                       <+> text "must all be type variables" ]) tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl" tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)]   = panic "tcDefaultAssocDecl"@@ -1544,8 +1576,8 @@ Consider this default declaration for an associated type     class C a where-      type F (a :: k) b :: *-      type F x y = Proxy x -> y+      type F (a :: k) b :: Type+      type F (x :: j) y = Proxy x -> y  Note that the class variable 'a' doesn't scope over the default assoc decl (rather oddly I think), and (less oddly) neither does the second@@ -1555,17 +1587,26 @@  However we store the default rhs (Proxy x -> y) in F's TyCon, using F's own type variables, so we need to convert it to (Proxy a -> b).-We do this by calling tcMatchTys to match them up.  This also ensures-that x's kind matches a's and similarly for y and b.  The error-message isn't great, mind you.  (#11361 was caused by not doing a-proper tcMatchTys here.)+We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and+applying this substitution to the RHS. -Recall also that the left-hand side of an associated type family-default is always just variables -- no tycons here. Accordingly,-the patterns used in the tcMatchTys won't actually be knot-tied,-even though we're in the knot. This is too delicate for my taste,-but it works.+In order to create this substitution, we must first ensure that all of+the arguments in the default instance consist of type variables. The parser+already checks this to a certain degree (see RdrHsSyn.checkTyVars), but+we must be wary of kind arguments being instantiated, which the parser cannot+catch so easily. Consider this erroneous program (inspired by #11361): +   class C a where+      type F (a :: k) b :: Type+      type F x        b = x++If you squint, you'll notice that the kind of `x` is actually Type. However,+we cannot substitute from [Type |-> k], so we reject this default.++Since the LHS of an associated type family default is always just variables,+it won't contain any tycons. Accordingly, the patterns used in the substitution+won't actually be knot-tied, even though we're in the knot. This is too+delicate for my taste, but it works. -}  {- *********************************************************************@@ -3848,11 +3889,6 @@ wrongNumberOfParmsErr max_args   = text "Number of parameters must match family declaration; expected"     <+> ppr max_args--defaultAssocKindErr :: TyCon -> SDoc-defaultAssocKindErr fam_tc-  = text "Kind mis-match on LHS of default declaration for"-    <+> quotes (ppr fam_tc)  badRoleAnnot :: Name -> Role -> Role -> SDoc badRoleAnnot var annot inferred

@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20190402+version: 0.20190423 license: BSD3 license-file: LICENSE category: Development@@ -52,7 +52,7 @@ tested-with:GHC==8.6.3 source-repository head     type: git-    location: git://git.haskell.org/ghc.git+    location: git@github.com:digital-asset/ghc-lib.git  library     default-language:   Haskell2010@@ -84,7 +84,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 0.20190402+        ghc-lib-parser == 0.20190423     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns

@@ -5,7 +5,8 @@ # define __GLASGOW_HASKELL__ 809 #endif -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20190402+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190423  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \

@@ -1,35 +1,34 @@-[("GCC extra via C opts", " -fwrapv -fno-builtin"),- ("C compiler command", "gcc"),- ("C compiler flags", ""),- ("C compiler link flags", " "),- ("C compiler supports -no-pie", "NO"),- ("Haskell CPP command","gcc"),- ("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),- ("ld command", "ld"),- ("ld flags", ""),- ("ld supports compact unwind", "YES"),- ("ld supports build-id", "NO"),- ("ld supports filelist", "YES"),- ("ld is GNU ld", "NO"),- ("ar command", "ar"),- ("ar flags", "qcls"),- ("ar supports at file", "NO"),- ("ranlib command", "ranlib"),- ("touch command", "touch"),- ("dllwrap command", "/bin/false"),- ("windres command", "/bin/false"),- ("libtool command", "libtool"),- ("cross compiling", "NO"),- ("target os", "OSDarwin"),- ("target arch", "ArchX86_64"),- ("target word size", "8"),- ("target has GNU nonexec stack", "False"),- ("target has .ident directive", "True"),- ("target has subsections via symbols", "True"),- ("target has RTS linker", "YES"),- ("Unregisterised", "NO"),- ("LLVM llc command", "llc"),- ("LLVM opt command", "opt"),- ("LLVM clang command", "clang")- ]-+[("GCC extra via C opts", " -fwrapv -fno-builtin")+,("C compiler command", "gcc")+,("C compiler flags", "")+,("C compiler link flags", " ")+,("C compiler supports -no-pie", "NO")+,("Haskell CPP command", "gcc")+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")+,("ld command", "ld")+,("ld flags", "")+,("ld supports compact unwind", "YES")+,("ld supports build-id", "NO")+,("ld supports filelist", "YES")+,("ld is GNU ld", "NO")+,("ar command", "ar")+,("ar flags", "qcls")+,("ar supports at file", "NO")+,("ranlib command", "ranlib")+,("touch command", "touch")+,("dllwrap command", "/bin/false")+,("windres command", "/bin/false")+,("libtool command", "libtool")+,("cross compiling", "NO")+,("target os", "OSDarwin")+,("target arch", "ArchX86_64")+,("target word size", "8")+,("target has GNU nonexec stack", "False")+,("target has .ident directive", "True")+,("target has subsections via symbols", "True")+,("target has RTS linker", "YES")+,("Unregisterised", "NO")+,("LLVM llc command", "llc")+,("LLVM opt command", "opt")+,("LLVM clang command", "clang")+]

@@ -102,7 +102,7 @@ import Data.Function import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,-                   partition, sort, sortBy )+                   partition, sort, sortBy, (\\) ) import qualified Data.Set as S import Data.Maybe import Data.Map (Map)@@ -351,13 +351,16 @@   "\n" ++   "   :set <option> ...           set options\n" ++   "   :seti <option> ...          set options for interactive evaluation only\n" +++  "   :set local-config { source | ignore }\n" +++  "                               set whether to source .ghci in current dir\n" +++  "                               (loading untrusted config is a security issue)\n" ++   "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++   "   :set prog <progname>        set the value returned by System.getProgName\n" ++   "   :set prompt <prompt>        set the prompt used in GHCi\n" ++   "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" ++   "   :set prompt-function <expr> set the function to handle the prompt\n" ++-  "   :set prompt-cont-function <expr>" ++-                     "set the function to handle the continuation prompt\n" +++  "   :set prompt-cont-function <expr>\n" +++  "                               set the function to handle the continuation prompt\n" ++   "   :set editor <cmd>           set the command used for :edit\n" ++   "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++   "   :unset <option> ...         unset options\n" ++@@ -482,6 +485,7 @@                    stop               = default_stop,                    editor             = default_editor,                    options            = [],+                   localConfig        = SourceLocalConfig,                    -- We initialize line number as 0, not 1, because we use                    -- current line number while reporting errors which is                    -- incremented after reading a line.@@ -566,8 +570,6 @@   let    ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags -   current_dir = return (Just ".ghci")-    app_user_dir = liftIO $ withGhcAppData                     (\dir -> return (Just (dir </> "ghci.conf")))                     (return Nothing)@@ -606,18 +608,45 @@    setGHCContextFromGHCiState -  dot_cfgs <- if ignore_dot_ghci then return [] else do-    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]-    liftIO $ filterM checkFileAndDirPerms dot_files-  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs+  processedCfgs <- if ignore_dot_ghci+    then pure []+    else do+      userCfgs <- do+        paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]+        checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths+        liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths +      localCfg <- do+        let path = ".ghci"+        ok <- liftIO $ checkFileAndDirPerms path+        if ok then liftIO $ canonicalizePath' path else pure Nothing++      mapM_ sourceConfigFile userCfgs+        -- Process the global and user .ghci+        -- (but not $CWD/.ghci or CLI args, yet)++      behaviour <- localConfig <$> getGHCiState++      processedLocalCfg <- case localCfg of+        Just path | path `notElem` userCfgs ->+          -- don't read .ghci twice if CWD is $HOME+          case behaviour of+            SourceLocalConfig -> localCfg <$ sourceConfigFile path+            IgnoreLocalConfig -> pure Nothing+        _ -> pure Nothing++      pure $ maybe id (:) processedLocalCfg userCfgs+   let arg_cfgs = reverse $ ghciScripts dflags     -- -ghci-script are collected in reverse order     -- We don't require that a script explicitly added by -ghci-script     -- is owned by the current user. (#6017)-  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs-    -- nub, because we don't want to read .ghci twice if the CWD is $HOME. +  mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs+    -- Dedup, and remove any configs we already processed.+    -- Importantly, if $PWD/.ghci was ignored due to configuration,+    -- explicitly specifying it does cause it to be processed.+   -- Perform a :load for files given on the GHCi command line   -- When in -e mode, if the load fails then we want to stop   -- immediately rather than going on to evaluate the expression.@@ -2117,7 +2146,9 @@      let fs    = mkFastString fp         span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)-                              (mkRealSrcLoc fs el ec)+                              -- End column of RealSrcSpan is the column+                              -- after the end of the span.+                              (mkRealSrcLoc fs el (ec + 1))      return (span',trailer)   where@@ -2163,7 +2194,9 @@     sl = srcSpanStartLine spn     sc = srcSpanStartCol  spn     el = srcSpanEndLine   spn-    ec = srcSpanEndCol    spn+    -- The end column is the column after the end of the span see the+    -- RealSrcSpan module+    ec = let ec' = srcSpanEndCol    spn in if ec' == 0 then 0 else ec' - 1  ----------------------------------------------------------------------------- -- | @:kind@ command@@ -2663,6 +2696,8 @@      Right ("editor",  rest) -> setEditor  $ dropWhile isSpace rest     Right ("stop",    rest) -> setStop    $ dropWhile isSpace rest+    Right ("local-config", rest) ->+        setLocalConfigBehaviour $ dropWhile isSpace rest     _ -> case toArgs str of          Left err -> liftIO (hPutStrLn stderr err)          Right wds -> setOptions wds@@ -2728,6 +2763,7 @@  setArgs, setOptions :: GhciMonad m => [String] -> m () setProg, setEditor, setStop :: GhciMonad m => String -> m ()+setLocalConfigBehaviour :: GhciMonad m => String -> m ()  setArgs args = do   st <- getGHCiState@@ -2740,6 +2776,14 @@   setGHCiState st { progname = prog, evalWrapper = wrapper }  setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setLocalConfigBehaviour s+  | s == "source" =+      modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })+  | s == "ignore" =+      modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })+  | otherwise = throwGhcException+      (CmdLineError "syntax:  :set local-config { source | ignore }")  setStop str@(c:_) | isDigit c   = do let (nm_str,rest) = break (not.isDigit) str

@@ -75,6 +75,9 @@       -- locality, definition location, etc.     } +instance Outputable SpanInfo where+  ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i+ -- | Test whether second span is contained in (or equal to) first span. -- This is basically 'containsSpan' for 'SpanInfo' containsSpanInfo :: SpanInfo -> SpanInfo -> Bool

@@ -15,6 +15,7 @@         GHCiState(..), GhciMonad(..),         GHCiOption(..), isOptionSet, setOption, unsetOption,         Command(..), CommandResult(..), cmdSuccess,+        LocalConfigBehaviour(..),         PromptFunction,         BreakLocation(..),         TickArray,@@ -79,6 +80,7 @@         prompt_cont    :: PromptFunction,         editor         :: String,         stop           :: String,+        localConfig    :: LocalConfigBehaviour,         options        :: [GHCiOption],         line_number    :: !Int,         -- ^ input line         break_ctr      :: !Int,@@ -196,6 +198,15 @@         | CollectInfo           -- collect and cache information about                                 -- modules after load         deriving Eq++-- | Treatment of ./.ghci files.  For now we either load or+-- ignore.  But later we could implement a "safe mode" where+-- only safe operations are performed.+--+data LocalConfigBehaviour+  = SourceLocalConfig+  | IgnoreLocalConfig+  deriving (Eq)  data BreakLocation    = BreakLocation

@@ -41,65 +41,59 @@ #  define r15   15 # endif -# define fake0 16-# define fake1 17-# define fake2 18-# define fake3 19-# define fake4 20-# define fake5 21  -- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence -- being assigned the same RegNos.-# define xmm0  24-# define xmm1  25-# define xmm2  26-# define xmm3  27-# define xmm4  28-# define xmm5  29-# define xmm6  30-# define xmm7  31-# define xmm8  32-# define xmm9  33-# define xmm10 34-# define xmm11 35-# define xmm12 36-# define xmm13 37-# define xmm14 38-# define xmm15 39+# define xmm0  16+# define xmm1  17+# define xmm2  18+# define xmm3  19+# define xmm4  20+# define xmm5  21+# define xmm6  22+# define xmm7  23+# define xmm8  24+# define xmm9  25+# define xmm10 26+# define xmm11 27+# define xmm12 28+# define xmm13 29+# define xmm14 30+# define xmm15 31 -# define ymm0  24-# define ymm1  25-# define ymm2  26-# define ymm3  27-# define ymm4  28-# define ymm5  29-# define ymm6  30-# define ymm7  31-# define ymm8  32-# define ymm9  33-# define ymm10 34-# define ymm11 35-# define ymm12 36-# define ymm13 37-# define ymm14 38-# define ymm15 39+# define ymm0  16+# define ymm1  17+# define ymm2  18+# define ymm3  19+# define ymm4  20+# define ymm5  21+# define ymm6  22+# define ymm7  23+# define ymm8  24+# define ymm9  25+# define ymm10 26+# define ymm11 27+# define ymm12 28+# define ymm13 29+# define ymm14 30+# define ymm15 31 -# define zmm0  24-# define zmm1  25-# define zmm2  26-# define zmm3  27-# define zmm4  28-# define zmm5  29-# define zmm6  30-# define zmm7  31-# define zmm8  32-# define zmm9  33-# define zmm10 34-# define zmm11 35-# define zmm12 36-# define zmm13 37-# define zmm14 38-# define zmm15 39+# define zmm0  16+# define zmm1  17+# define zmm2  18+# define zmm3  19+# define zmm4  20+# define zmm5  21+# define zmm6  22+# define zmm7  23+# define zmm8  24+# define zmm9  25+# define zmm10 26+# define zmm11 27+# define zmm12 28+# define zmm13 29+# define zmm14 30+# define zmm15 31  -- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs. -- Since it's only used to check 'isJust', the actual values don't matter, thus