diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -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. +-} diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -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 diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -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) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -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 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -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 () diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -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 diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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 diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs --- a/compiler/deSugar/TmOracle.hs +++ b/compiler/deSugar/TmOracle.hs @@ -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 diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -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" ]) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -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' diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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", diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -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 diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -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 = [], diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs --- a/compiler/main/SysTools/ExtraObj.hs +++ b/compiler/main/SysTools/ExtraObj.hs @@ -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", diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -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) diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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 diff --git a/compiler/nativeGen/Format.hs b/compiler/nativeGen/Format.hs --- a/compiler/nativeGen/Format.hs +++ b/compiler/nativeGen/Format.hs @@ -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 diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -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)]), diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -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 diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -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', diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -131,7 +131,7 @@ RcInteger -> text "blue" RcFloat -> text "red" RcDouble -> text "green" - RcDoubleSSE -> text "yellow" + -- immediates ------------------------------------------------------------------ diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -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 diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -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 ---------------------------------------------------------- diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -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" diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -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" diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -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" - diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -104,7 +104,6 @@ VirtualRegD{} -> 1 _other -> 0 - _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. diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -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 [ diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -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 -- diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -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 - - fcomp 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 diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -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" diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -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 diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -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 diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs --- a/compiler/simplStg/StgCse.hs +++ b/compiler/simplStg/StgCse.hs @@ -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 diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -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] diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -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 diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -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 => --- newMethodFromName is supposed to instantiate just the outer +-- +-- > forall a. C a => +-- +-- '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 diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -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) [] diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -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 diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -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 diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -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 diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -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 diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -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 diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -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 } diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.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 diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -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__ || \ diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings --- a/ghc-lib/stage1/lib/settings +++ b/ghc-lib/stage1/lib/settings @@ -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") +] diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -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