ghc-lib 9.12.2.20250421 → 9.12.3.20251228
raw patch · 78 files changed
+2265/−883 lines, 78 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +1/−5
- compiler/GHC/ByteCode/Instr.hs +12/−1
- compiler/GHC/Cmm/Config.hs +2/−0
- compiler/GHC/Cmm/Opt.hs +600/−37
- compiler/GHC/Cmm/Parser.y +4/−1
- compiler/GHC/Cmm/Pipeline.hs +6/−3
- compiler/GHC/Cmm/Sink.hs +68/−62
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +22/−7
- compiler/GHC/CmmToAsm/Config.hs +1/−0
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs +2/−1
- compiler/GHC/CmmToAsm/RV64/Instr.hs +10/−1
- compiler/GHC/CmmToAsm/RV64/Ppr.hs +1/−0
- compiler/GHC/CmmToAsm/Wasm/Asm.hs +1/−0
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +27/−5
- compiler/GHC/CmmToAsm/Wasm/Types.hs +1/−0
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +42/−19
- compiler/GHC/CmmToAsm/X86/Instr.hs +13/−17
- compiler/GHC/CmmToAsm/X86/Ppr.hs +15/−18
- compiler/GHC/CmmToC.hs +1/−1
- compiler/GHC/CmmToLlvm.hs +9/−8
- compiler/GHC/CmmToLlvm/Base.hs +9/−7
- compiler/GHC/CmmToLlvm/CodeGen.hs +88/−64
- compiler/GHC/CmmToLlvm/Data.hs +1/−1
- compiler/GHC/Core/LateCC/OverloadedCalls.hs +39/−15
- compiler/GHC/Core/Opt/CprAnal.hs +67/−14
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +16/−9
- compiler/GHC/CoreToStg/Prep.hs +1/−0
- compiler/GHC/Driver/Config/Cmm.hs +12/−0
- compiler/GHC/Driver/Config/CmmToAsm.hs +1/−0
- compiler/GHC/Driver/Pipeline/Execute.hs +7/−5
- compiler/GHC/HsToCore/Binds.hs +5/−5
- compiler/GHC/HsToCore/Foreign/C.hs +3/−4
- compiler/GHC/HsToCore/Foreign/Wasm.hs +299/−263
- compiler/GHC/HsToCore/GuardedRHSs.hs +26/−18
- compiler/GHC/HsToCore/Quote.hs +1/−1
- compiler/GHC/Iface/Load.hs +6/−2
- compiler/GHC/Iface/Make.hs +2/−2
- compiler/GHC/Iface/Rename.hs +10/−0
- compiler/GHC/Iface/Tidy.hs +3/−3
- compiler/GHC/IfaceToCore.hs +64/−19
- compiler/GHC/IfaceToCore.hs-boot +3/−4
- compiler/GHC/Linker/Dynamic.hs +0/−4
- compiler/GHC/Linker/Static.hs +7/−0
- compiler/GHC/Llvm/Ppr.hs +1/−3
- compiler/GHC/Llvm/Types.hs +1/−1
- compiler/GHC/Plugins.hs +1/−1
- compiler/GHC/Rename/Bind.hs +29/−5
- compiler/GHC/Rename/Names.hs +140/−41
- compiler/GHC/Rename/Splice.hs +1/−1
- compiler/GHC/Runtime/Eval.hs +2/−2
- compiler/GHC/Settings/IO.hs +36/−28
- compiler/GHC/StgToByteCode.hs +18/−13
- compiler/GHC/StgToCmm/Monad.hs +11/−1
- compiler/GHC/StgToCmm/Prim.hs +16/−33
- compiler/GHC/SysTools/Ar.hs +1/−1
- compiler/GHC/SysTools/Process.hs +3/−1
- compiler/GHC/SysTools/Tasks.hs +8/−5
- compiler/GHC/Tc/Gen/App.hs +4/−0
- compiler/GHC/Tc/Gen/Arrow.hs +2/−1
- compiler/GHC/Tc/Gen/Bind.hs +34/−12
- compiler/GHC/Tc/Gen/Default.hs +16/−17
- compiler/GHC/Tc/Gen/Export.hs +3/−2
- compiler/GHC/Tc/Gen/Expr.hs +1/−1
- compiler/GHC/Tc/Gen/Foreign.hs +2/−2
- compiler/GHC/Tc/Gen/Match.hs +58/−11
- compiler/GHC/Tc/Gen/Splice.hs +2/−2
- compiler/GHC/Tc/Gen/Splice.hs-boot +1/−1
- compiler/GHC/Tc/Module.hs +8/−7
- compiler/GHC/Tc/Solver.hs +5/−5
- compiler/GHC/Tc/Solver/Dict.hs +16/−11
- compiler/GHC/Tc/Solver/Equality.hs +40/−16
- compiler/GHC/Tc/Solver/Monad.hs +85/−6
- compiler/GHC/Tc/TyCl.hs +2/−0
- compiler/GHC/Tc/Utils/Env.hs +30/−12
- compiler/GHC/Tc/Utils/Unify.hs +8/−1
- compiler/GHC/ThToHs.hs +1/−1
- ghc-lib.cabal +21/−13
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +150/−0
compiler/GHC.hs view
@@ -713,11 +713,7 @@ #if defined(wasm32_HOST_ARCH) let libdir = sorry "cannot spawn child process on wasm" #else- libdir <- liftIO $ do- libdirs <- Loader.getGccSearchDirectory logger dflags "libraries"- case libdirs of- [_, libdir] -> pure libdir- _ -> panic "corrupted wasi-sdk installation"+ libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" #endif let profiled = ways dflags `hasWay` WayProf way_tag = if profiled then "_p" else ""
compiler/GHC/ByteCode/Instr.hs view
@@ -130,7 +130,18 @@ | PUSH_APPLY_PPPPP | PUSH_APPLY_PPPPPP - | SLIDE !WordOff{-this many-} !WordOff{-down by this much-}+ -- | Drop entries @(n, n+by]@ entries from the stack. Graphically:+ -- @+ -- a_1 ← top+ -- ...+ -- a_n+ -- b_1 => a_1 ← top+ -- ... ...+ -- b_by a_n+ -- k k+ -- @+ | SLIDE !WordOff -- ^ n = this many+ !WordOff -- ^ by = down by this much -- To do with the heap | ALLOC_AP !HalfWord {- make an AP with this many payload words.
compiler/GHC/Cmm/Config.hs view
@@ -24,6 +24,8 @@ , cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries , cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements , cmmSplitProcPoints :: !Bool -- ^ Should Cmm split proc points or not+ , cmmAllowMul2 :: !Bool -- ^ Does this platform support mul2+ , cmmOptConstDivision :: !Bool -- ^ Should we optimize constant divisors } -- | retrieve the target Cmm platform
compiler/GHC/Cmm/Opt.hs view
@@ -5,27 +5,53 @@ -- (c) The University of Glasgow 2006 -- -----------------------------------------------------------------------------+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PatternSynonyms #-} module GHC.Cmm.Opt ( constantFoldNode, constantFoldExpr, cmmMachOpFold,- cmmMachOpFoldM+ cmmMachOpFoldM,+ Opt, runOpt ) where import GHC.Prelude +import GHC.Cmm.Dataflow.Block import GHC.Cmm.Utils import GHC.Cmm-import GHC.Utils.Misc+import GHC.Cmm.Config+import GHC.Types.Unique.DSM +import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Outputable import GHC.Platform import Data.Maybe+import GHC.Float+import Data.Word+import GHC.Exts (oneShot)+import Control.Monad +constantFoldNode :: CmmNode e x -> Opt (CmmNode e x)+constantFoldNode (CmmUnsafeForeignCall (PrimTarget op) res args)+ = traverse constantFoldExprOpt args >>= cmmCallishMachOpFold op res+constantFoldNode node+ = mapExpOpt constantFoldExprOpt node -constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x-constantFoldNode platform = mapExp (constantFoldExpr platform)+constantFoldExprOpt :: CmmExpr -> Opt CmmExpr+constantFoldExprOpt e = wrapRecExpOpt f e+ where+ f (CmmMachOp op args)+ = do+ cfg <- getConfig+ case cmmMachOpFold (cmmPlatform cfg) op args of+ CmmMachOp op' args' -> fromMaybe (CmmMachOp op' args') <$> cmmMachOpFoldOptM cfg op' args'+ e -> pure e+ f (CmmRegOff r 0) = pure (CmmReg r)+ f e = pure e constantFoldExpr :: Platform -> CmmExpr -> CmmExpr constantFoldExpr platform = wrapRecExp f@@ -63,8 +89,27 @@ [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l) _ -> Nothing cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]+ | MO_WF_Bitcast width <- op = case width of+ W32 | res <- castWord32ToFloat (fromInteger x)+ -- Since we store float literals as Rationals+ -- we must check for the usual tricky cases first+ , not (isNegativeZero res || isNaN res || isInfinite res)+ -- (round-tripping subnormals is not a problem)+ , !res_rat <- toRational res+ -> Just (CmmLit (CmmFloat res_rat W32))++ W64 | res <- castWord64ToDouble (fromInteger x)+ -- Since we store float literals as Rationals+ -- we must check for the usual tricky cases first+ , not (isNegativeZero res || isNaN res || isInfinite res)+ -- (round-tripping subnormals is not a problem)+ , !res_rat <- toRational res+ -> Just (CmmLit (CmmFloat res_rat W64))++ _ -> Nothing+ | otherwise = Just $! case op of- MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)+ MO_S_Neg _ -> CmmLit (CmmInt (narrowS rep (-x)) rep) MO_Not _ -> CmmLit (CmmInt (complement x) rep) -- these are interesting: we must first narrow to the@@ -75,7 +120,20 @@ MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to)++ MO_F_Neg{} -> invalidArgPanic+ MO_FS_Truncate{} -> invalidArgPanic+ MO_FF_Conv{} -> invalidArgPanic+ MO_FW_Bitcast{} -> invalidArgPanic+ MO_VS_Neg{} -> invalidArgPanic+ MO_VF_Neg{} -> invalidArgPanic+ MO_RelaxedRead{} -> invalidArgPanic+ MO_AlignmentCheck{} -> invalidArgPanic+ _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op+ where invalidArgPanic = pprPanic "cmmMachOpFoldM" $+ text "Found" <+> pprMachOp op+ <+> text "illegally applied to an int literal" -- Eliminate shifts that are wider than the shiftee cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)]@@ -296,7 +354,7 @@ maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) maybe_comparison _ _ _ = Nothing --- We can often do something with constants of 0 and 1 ...+-- We can often do something with constants of 0, 1 and (-1) ... -- See Note [Comparison operators] cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]@@ -367,6 +425,8 @@ MO_Mul rep | Just p <- exactLog2 n -> Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)])+ -- The optimization for division by power of 2 is technically duplicated, but since at least one other part of ghc uses+ -- the pure `constantFoldExpr` this remains MO_U_Quot rep | Just p <- exactLog2 n -> Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)])@@ -375,46 +435,19 @@ Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) MO_S_Quot rep | Just p <- exactLog2 n,- CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require- -- it is a reg. FIXME: remove this restriction.+ CmmReg _ <- x -> Just $! (cmmMachOpFold platform (MO_S_Shr rep)- [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])+ [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt p $ wordWidth platform)]) MO_S_Rem rep | Just p <- exactLog2 n,- CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require- -- it is a reg. FIXME: remove this restriction.+ CmmReg _ <- x -> -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p). -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot) -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation. Just $! (cmmMachOpFold platform (MO_Sub rep) [x, cmmMachOpFold platform (MO_And rep)- [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])+ [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt (- n) rep)]]) _ -> Nothing- where- -- In contrast with unsigned integers, for signed ones- -- shift right is not the same as quot, because it rounds- -- to minus infinity, whereas quot rounds toward zero.- -- To fix this up, we add one less than the divisor to the- -- dividend if it is a negative number.- --- -- to avoid a test/jump, we use the following sequence:- -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve)- -- x2 = y & (divisor-1)- -- result = x + x2- -- this could be done a bit more simply using conditional moves,- -- but we're processor independent here.- --- -- we optimise the divide by 2 case slightly, generating- -- x1 = x >> word_size-1 (unsigned)- -- return = x + x1- signedQuotRemHelper :: Width -> Integer -> CmmExpr- signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]- where- bits = fromIntegral (widthInBits rep) - 1- shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep- x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]- x2 = if p == 1 then x1 else- CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x -- Unfortunately this needs a unique supply because x might not be a@@ -448,3 +481,533 @@ isPicReg :: CmmExpr -> Bool isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False++canOptimizeDivision :: CmmConfig -> Width -> Bool+canOptimizeDivision cfg rep = cmmOptConstDivision cfg &&+ -- we can either widen the arguments to simulate mul2 or use mul2 directly for the platform word size+ (rep < wordWidth platform || (rep == wordWidth platform && cmmAllowMul2 cfg))+ where platform = cmmPlatform cfg++-- -----------------------------------------------------------------------------+-- Folding callish machops++cmmCallishMachOpFold :: CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (CmmNode O O)+cmmCallishMachOpFold op res args =+ fromMaybe (CmmUnsafeForeignCall (PrimTarget op) res args) <$> (getConfig >>= \cfg -> cmmCallishMachOpFoldM cfg op res args)++cmmCallishMachOpFoldM :: CmmConfig -> CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (Maybe (CmmNode O O))++-- If possible move the literals to the right, the following cases assume that to be the case+cmmCallishMachOpFoldM cfg op res [x@(CmmLit _),y]+ | isCommutableCallishMachOp op && not (isLit y) = cmmCallishMachOpFoldM cfg op res [y,x]++-- Both arguments are literals, replace with the result+cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt x _), CmmLit (CmmInt y _)]+ = case op of+ MO_S_Mul2 rep+ | [rHiNeeded,rHi,rLo] <- res -> do+ let resSz = widthInBits rep+ resVal = (narrowS rep x) * (narrowS rep y)+ high = resVal `shiftR` resSz+ low = narrowS rep resVal+ isHiNeeded = high /= low `shiftR` resSz+ isHiNeededVal = if isHiNeeded then 1 else 0+ prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt isHiNeededVal rep)+ prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep)+ pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep)+ MO_U_Mul2 rep+ | [rHi,rLo] <- res -> do+ let resSz = widthInBits rep+ resVal = (narrowU rep x) * (narrowU rep y)+ high = resVal `shiftR` resSz+ low = narrowU rep resVal+ prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep)+ pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep)+ MO_S_QuotRem rep+ | [rQuot, rRem] <- res,+ y /= 0 -> do+ let (q,r) = quotRem (narrowS rep x) (narrowS rep y)+ prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep)+ pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep)+ MO_U_QuotRem rep+ | [rQuot, rRem] <- res,+ y /= 0 -> do+ let (q,r) = quotRem (narrowU rep x) (narrowU rep y)+ prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep)+ pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep)+ _ -> pure Nothing++-- 0, 1 or -1 as one of the constants++cmmCallishMachOpFoldM _ op res [_, CmmLit (CmmInt 0 _)]+ = case op of+ -- x * 0 == 0+ MO_S_Mul2 rep+ | [rHiNeeded, rHi, rLo] <- res -> do+ prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep)+ prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)+ pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep)+ -- x * 0 == 0+ MO_U_Mul2 rep+ | [rHi, rLo] <- res -> do+ prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)+ pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep)+ _ -> pure Nothing++cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt 0 _), _]+ = case op of+ -- 0 quotRem d == (0,0)+ MO_S_QuotRem rep+ | [rQuot, rRem] <- res -> do+ prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep)+ pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)+ -- 0 quotRem d == (0,0)+ MO_U_QuotRem rep+ | [rQuot,rRem] <- res -> do+ prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep)+ pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)+ _ -> pure Nothing++cmmCallishMachOpFoldM cfg op res [x, CmmLit (CmmInt 1 _)]+ = case op of+ -- x * 1 == x -- Note: The high word needs to be a sign extension of the low word, so we use a sign extending shift+ MO_S_Mul2 rep+ | [rHiNeeded, rHi, rLo] <- res -> do+ let platform = cmmPlatform cfg+ wordRep = wordWidth platform+ repInBits = toInteger $ widthInBits rep+ prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep)+ prependNode $! CmmAssign (CmmLocal rHi) (cmmMachOpFold platform (MO_S_Shr rep) [x, CmmLit $ CmmInt (repInBits - 1) wordRep])+ pure . Just $! CmmAssign (CmmLocal rLo) x+ -- x * 1 == x+ MO_U_Mul2 rep+ | [rHi, rLo] <- res -> do+ prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)+ pure . Just $! CmmAssign (CmmLocal rLo) x+ -- x quotRem 1 == (x, 0)+ MO_S_QuotRem rep+ | [rQuot, rRem] <- res -> do+ prependNode $! CmmAssign (CmmLocal rQuot) x+ pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)+ -- x quotRem 1 == (x, 0)+ MO_U_QuotRem rep+ | [rQuot, rRem] <- res -> do+ prependNode $! CmmAssign (CmmLocal rQuot) x+ pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)+ _ -> pure Nothing++-- handle quotRem with a constant divisor++cmmCallishMachOpFoldM cfg op res [n, CmmLit (CmmInt d' _)]+ = case op of+ MO_S_QuotRem rep+ | Just p <- exactLog2 d,+ [rQuot,rRem] <- res -> do+ n' <- intoRegister n (cmmBits rep)+ -- first prepend the optimized division by a power 2+ prependNode $! CmmAssign (CmmLocal rQuot)+ (cmmMachOpFold platform (MO_S_Shr rep)+ [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt p $ wordWidth platform)])+ -- then output an optimized remainder by a power of 2+ pure . Just $! CmmAssign (CmmLocal rRem)+ (cmmMachOpFold platform (MO_Sub rep)+ [n', cmmMachOpFold platform (MO_And rep)+ [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt (- d) rep)]])+ | canOptimizeDivision cfg rep,+ d /= (-1), d /= 0, d /= 1,+ [rQuot,rRem] <- res -> do+ -- we are definitely going to use n multiple times, so put it into a register+ n' <- intoRegister n (cmmBits rep)+ -- generate an optimized (signed) division of n by d+ q <- generateDivisionBySigned platform cfg rep n' d+ -- we also need the result multiple times to calculate the remainder+ q' <- intoRegister q (cmmBits rep)++ prependNode $! CmmAssign (CmmLocal rQuot) q'+ -- The remainder now becomes n - q * d+ pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]+ where+ platform = cmmPlatform cfg+ d = narrowS rep d'+ MO_U_QuotRem rep+ | Just p <- exactLog2 d,+ [rQuot,rRem] <- res -> do+ -- first prepend the optimized division by a power 2+ prependNode $! CmmAssign (CmmLocal rQuot) $ CmmMachOp (MO_U_Shr rep) [n, CmmLit (CmmInt p $ wordWidth platform)]+ -- then output an optimized remainder by a power of 2+ pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_And rep) [n, CmmLit (CmmInt (d - 1) rep)]+ | canOptimizeDivision cfg rep,+ d /= 0, d /= 1,+ [rQuot,rRem] <- res -> do+ -- we are definitely going to use n multiple times, so put it into a register+ n' <- intoRegister n (cmmBits rep)+ -- generate an optimized (unsigned) division of n by d+ q <- generateDivisionByUnsigned platform cfg rep n' d+ -- we also need the result multiple times to calculate the remainder+ q' <- intoRegister q (cmmBits rep)++ prependNode $! CmmAssign (CmmLocal rQuot) q'+ -- The remainder now becomes n - q * d+ pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]+ where+ platform = cmmPlatform cfg+ d = narrowU rep d'+ _ -> pure Nothing++cmmCallishMachOpFoldM _ _ _ _ = pure Nothing++-- -----------------------------------------------------------------------------+-- Specialized constant folding for MachOps which sometimes need to expand into multiple nodes++cmmMachOpFoldOptM :: CmmConfig -> MachOp -> [CmmExpr] -> Opt (Maybe CmmExpr)++cmmMachOpFoldOptM cfg op [n, CmmLit (CmmInt d' _)] =+ case op of+ MO_S_Quot rep+ -- recheck for power of 2 division. This may not be handled by cmmMachOpFoldM if n is not in a register+ | Just p <- exactLog2 d -> do+ n' <- intoRegister n (cmmBits rep)+ pure . Just $! cmmMachOpFold platform (MO_S_Shr rep)+ [ signedQuotRemHelper platform d n' rep p+ , CmmLit (CmmInt p $ wordWidth platform)+ ]+ | canOptimizeDivision cfg rep,+ d /= (-1), d /= 0, d /= 1 -> Just <$!> generateDivisionBySigned platform cfg rep n d+ where d = narrowS rep d'+ MO_S_Rem rep+ -- recheck for power of 2 remainder. This may not be handled by cmmMachOpFoldM if n is not in a register+ | Just p <- exactLog2 d -> do+ n' <- intoRegister n (cmmBits rep)+ pure . Just $! cmmMachOpFold platform (MO_Sub rep)+ [ n'+ , cmmMachOpFold platform (MO_And rep)+ [ signedQuotRemHelper platform d n' rep p+ , CmmLit (CmmInt (- d) rep)+ ]+ ]+ | canOptimizeDivision cfg rep,+ d /= (-1), d /= 0, d /= 1 -> do+ n' <- intoRegister n (cmmBits rep)+ -- first generate the division+ q <- generateDivisionBySigned platform cfg rep n' d+ -- then calculate the remainder by n - q * d+ pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]+ where d = narrowS rep d'+ MO_U_Quot rep+ -- No need to recheck power of 2 division because cmmMachOpFoldM always handles that case+ | canOptimizeDivision cfg rep,+ d /= 0, d /= 1, Nothing <- exactLog2 d -> Just <$!> generateDivisionByUnsigned platform cfg rep n d+ where d = narrowU rep d'+ MO_U_Rem rep+ -- No need to recheck power of 2 remainder because cmmMachOpFoldM always handles that case+ | canOptimizeDivision cfg rep,+ d /= 0, d /= 1, Nothing <- exactLog2 d -> do+ n' <- intoRegister n (cmmBits rep)+ -- first generate the division+ q <- generateDivisionByUnsigned platform cfg rep n d+ -- then calculate the remainder by n - q * d+ pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]+ where d = narrowU rep d'+ _ -> pure Nothing+ where platform = cmmPlatform cfg++cmmMachOpFoldOptM _ _ _ = pure Nothing++-- -----------------------------------------------------------------------------+-- Utils for prepending new nodes++-- Move an expression into a register to possibly use it multiple times+intoRegister :: CmmExpr -> CmmType -> Opt CmmExpr+intoRegister e@(CmmReg _) _ = pure e+intoRegister expr ty = do+ u <- getUniqueM+ let reg = LocalReg u ty+ CmmReg (CmmLocal reg) <$ prependNode (CmmAssign (CmmLocal reg) expr)++prependNode :: CmmNode O O -> Opt ()+prependNode n = Opt $ \_ xs -> pure (xs ++ [n], ())++-- -----------------------------------------------------------------------------+-- Division by constants utils++-- Helper for division by a power of 2+-- In contrast with unsigned integers, for signed ones+-- shift right is not the same as quot, because it rounds+-- to minus infinity, whereas quot rounds toward zero.+-- To fix this up, we add one less than the divisor to the+-- dividend if it is a negative number.+--+-- to avoid a test/jump, we use the following sequence:+-- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve)+-- x2 = y & (divisor-1)+-- result = x + x2+-- this could be done a bit more simply using conditional moves,+-- but we're processor independent here.+--+-- we optimize the divide by 2 case slightly, generating+-- x1 = x >> word_size-1 (unsigned)+-- return = x + x1+signedQuotRemHelper :: Platform -> Integer -> CmmExpr -> Width -> Integer -> CmmExpr+signedQuotRemHelper platform n x rep p = CmmMachOp (MO_Add rep) [x, x2]+ where+ bits = fromIntegral (widthInBits rep) - 1+ shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep+ x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]+ x2 = if p == 1 then x1 else+ CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]++{- Note: [Division by constants]++Integer division is floor(n / d), the goal is to find m,p+such that floor((m * n) / 2^p) = floor(n / d).++The idea being: n/d = n * (1/d). But we cannot store 1/d in an integer without+some error, so we choose some 2^p / d such that the error ends up small and+thus vanishes when we divide by 2^p again.++The algorithm below to generate these numbers is taken from Hacker's Delight+Second Edition Chapter 10 "Integer division by constants". The chapter also+contains proof that this method does indeed produce correct results.++However this is a much more literal interpretation of the algorithm,+which we can use because of the unbounded Integer type. Hacker's Delight+also provides a much more complex algorithm which computes these numbers+without the need to exceed the word size, but that is not necessary here.+-}++generateDivisionBySigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr++-- Sanity checks, division will generate incorrect results or undesirable code for these cases+-- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!+generateDivisionBySigned _ _ _ _ 0 = panic "generate signed division with 0"+generateDivisionBySigned _ _ _ _ 1 = panic "generate signed division with 1"+generateDivisionBySigned _ _ _ _ (-1) = panic "generate signed division with -1"+generateDivisionBySigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d++generateDivisionBySigned platform _cfg rep n divisor = do+ -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register+ n' <- if sign == 0 then pure n else intoRegister n resRep++ -- Set up mul2+ (shift', qExpr) <- mul2 n'++ -- add/subtract n if necessary+ let qExpr' = case sign of+ 1 -> CmmMachOp (MO_Add rep) [qExpr, n']+ -1 -> CmmMachOp (MO_Sub rep) [qExpr, n']+ _ -> qExpr++ qExpr'' <- intoRegister (cmmMachOpFold platform (MO_S_Shr rep) [qExpr', CmmLit $ CmmInt shift' wordRep]) resRep++ -- Lastly add the sign of the quotient to correct for negative results+ pure $! cmmMachOpFold platform+ (MO_Add rep) [qExpr'', cmmMachOpFold platform (MO_U_Shr rep) [qExpr'', CmmLit $ CmmInt (toInteger $ widthInBits rep - 1) wordRep]]+ where+ resRep = cmmBits rep+ wordRep = wordWidth platform+ (magic, sign, shift) = divisionMagicS rep divisor+ -- generate the multiply with the magic number+ mul2 n+ -- Using mul2 for sub-word sizes regresses for signed integers only+ | rep == wordWidth platform = do+ (r1, r2, r3) <- (,,) <$> getUniqueM <*> getUniqueM <*> getUniqueM+ let rg1 = LocalReg r1 resRep+ resReg = LocalReg r2 resRep+ rg3 = LocalReg r3 resRep+ res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_S_Mul2 rep)) [rg1, resReg, rg3] [n, CmmLit $ CmmInt magic rep])+ pure (shift, res)+ -- widen the register and multiply without the MUL2 instruction+ -- if we don't need an additional add after this we can combine the shifts+ | otherwise = pure (if sign == 0 then 0 else shift, res)+ where+ wordRep = wordWidth platform+ -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow+ res = cmmMachOpFold platform (MO_SS_Conv wordRep rep)+ [ cmmMachOpFold platform (MO_S_Shr wordRep)+ [ cmmMachOpFold platform (MO_Mul wordRep)+ [ cmmMachOpFold platform (MO_SS_Conv rep wordRep) [n]+ , CmmLit $ CmmInt magic wordRep+ ]+ -- Check if we need to generate an add/subtract later. If not we can combine this with the postshift+ , CmmLit $ CmmInt ((if sign == 0 then toInteger shift else 0) + (toInteger $ widthInBits rep)) wordRep+ ]+ ]++-- See hackers delight for how and why this works (chapter in note [Division by constants])+divisionMagicS :: Width -> Integer -> (Integer, Integer, Integer)+divisionMagicS rep divisor = (magic, sign, toInteger $ p - wSz)+ where+ sign = if divisor > 0+ then if magic < 0 then 1 else 0+ else if magic < 0 then 0 else -1+ wSz = widthInBits rep+ ad = abs divisor+ t = (1 `shiftL` (wSz - 1)) + if divisor > 0 then 0 else 1+ anc = t - 1 - rem t ad+ go p'+ | twoP > anc * (ad - rem twoP ad) = p'+ | otherwise = go (p' + 1)+ where twoP = 1 `shiftL` p'+ p = go wSz+ am = (twoP + ad - rem twoP ad) `quot` ad+ where twoP = 1 `shiftL` p+ magic = narrowS rep $ if divisor > 0 then am else -am++generateDivisionByUnsigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr+-- Sanity checks, division will generate incorrect results or undesirable code for these cases+-- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!+generateDivisionByUnsigned _ _ _ _ 0 = panic "generate signed division with 0"+generateDivisionByUnsigned _ _ _ _ 1 = panic "generate signed division with 1"+generateDivisionByUnsigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d++generateDivisionByUnsigned platform cfg rep n divisor = do+ -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register+ n' <- if not needsAdd -- Invariant: We also never preshift if we need an add, thus we don't need n in a register+ then pure $! cmmMachOpFold platform (MO_U_Shr rep) [n, CmmLit $ CmmInt preShift wordRep]+ else intoRegister n resRep++ -- Set up mul2+ (postShift', qExpr) <- mul2 n'++ -- add/subtract n if necessary+ let qExpr' = if needsAdd+ -- This is qExpr + (n - qExpr) / 2 = (qExpr + n) / 2 but with a guarantee that it'll not overflow+ then cmmMachOpFold platform (MO_Add rep)+ [ cmmMachOpFold platform (MO_U_Shr rep)+ [ cmmMachOpFold platform (MO_Sub rep) [n', qExpr]+ , CmmLit $ CmmInt 1 wordRep+ ]+ , qExpr+ ]+ else qExpr+ -- If we already divided by 2 in the add, remember to shift one bit less+ -- Hacker's Delight, Edition 2 Page 234: postShift > 0 if we needed an add, except if the divisor+ -- is 1, which we checked for above+ finalShift = if needsAdd then postShift' - 1 else postShift'++ -- apply the final postShift+ pure $! cmmMachOpFold platform (MO_U_Shr rep) [qExpr', CmmLit $ CmmInt finalShift wordRep]+ where+ resRep = cmmBits rep+ wordRep = wordWidth platform+ (preShift, magic, needsAdd, postShift) =+ let withPre = divisionMagicU rep True divisor+ noPre = divisionMagicU rep False divisor+ in case (withPre, noPre) of+ -- Use whatever does not cause us to take the expensive case+ ((_, _, False, _), (_, _, True, _)) -> withPre+ -- If we cannot avoid the expensive case, don't bother with the pre shift+ _ -> noPre+ -- generate the multiply with the magic number+ mul2 n+ | rep == wordWidth platform || (cmmAllowMul2 cfg && needsAdd) = do+ (r1, r2) <- (,) <$> getUniqueM <*> getUniqueM+ let rg1 = LocalReg r1 resRep+ resReg = LocalReg r2 resRep+ res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_U_Mul2 rep)) [resReg, rg1] [n, CmmLit $ CmmInt magic rep])+ pure (postShift, res)+ | otherwise = do+ pure (if needsAdd then postShift else 0, res)+ where+ wordRep = wordWidth platform+ -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow+ res = cmmMachOpFold platform (MO_UU_Conv wordRep rep)+ [ cmmMachOpFold platform (MO_U_Shr wordRep)+ [ cmmMachOpFold platform (MO_Mul wordRep)+ [ cmmMachOpFold platform (MO_UU_Conv rep wordRep) [n]+ , CmmLit $ CmmInt magic wordRep+ ]+ -- Check if we need to generate an add later. If not we can combine this with the postshift+ , CmmLit $ CmmInt ((if needsAdd then 0 else postShift) + (toInteger $ widthInBits rep)) wordRep+ ]+ ]++-- See hackers delight for how and why this works (chapter in note [Division by constants])+-- The preshift isn't described there, but the idea is:+-- If a divisor d has n trailing zeros, then d is a multiple of 2^n. Since we want to divide x by d+-- we can also calculate (x / 2^n) / (d / 2^n) which may then not require an extra addition.+--+-- The addition performs: quotient + dividend, but we need to avoid overflows, so we actually need to+-- calculate: quotient + (dividend - quotient) / 2 = (quotient + dividend) / 2+-- Thus if the preshift can avoid all of this, we have 1 operation in place of 3.+--+-- The decision to use the preshift is made somewhere else, here we only report if the addition is needed+divisionMagicU :: Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)+divisionMagicU rep doPreShift divisor = (toInteger zeros, magic, needsAdd, toInteger $ p - wSz)+ where+ wSz = widthInBits rep+ zeros = if doPreShift then countTrailingZeros $ fromInteger @Word64 divisor else 0+ d = divisor `shiftR` zeros+ ones = ((1 `shiftL` wSz) - 1) `shiftR` zeros+ nc = ones - rem (ones - d) d+ go p'+ | twoP > nc * (d - 1 - rem (twoP - 1) d) = p'+ | otherwise = go (p' + 1)+ where twoP = 1 `shiftL` p'+ p = go wSz+ m = (twoP + d - 1 - rem (twoP - 1) d) `quot` d+ where twoP = 1 `shiftL` p+ needsAdd = d < 1 `shiftL` (p - wSz)+ magic = if needsAdd then m - (ones + 1) else m++-- -----------------------------------------------------------------------------+-- Opt monad++newtype Opt a = OptI { runOptI :: CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a) }++-- | Pattern synonym for 'Opt', as described in Note [The one-shot state+-- monad trick].+pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a)) -> Opt a+pattern Opt f <- OptI f+ where Opt f = OptI . oneShot $ \cfg -> oneShot $ \out -> f cfg out+{-# COMPLETE Opt #-}++runOpt :: CmmConfig -> Opt a -> UniqDSM ([CmmNode O O], a)+runOpt cf (Opt g) = g cf []++getConfig :: Opt CmmConfig+getConfig = Opt $ \cf xs -> pure (xs, cf)++instance Functor Opt where+ fmap f (Opt g) = Opt $ \cf xs -> fmap (fmap f) (g cf xs)++instance Applicative Opt where+ pure a = Opt $ \_ xs -> pure (xs, a)+ ff <*> fa = do+ f <- ff+ f <$> fa++instance Monad Opt where+ Opt g >>= f = Opt $ \cf xs -> do+ (ys, a) <- g cf xs+ runOptI (f a) cf ys++instance MonadGetUnique Opt where+ getUniqueM = Opt $ \_ xs -> (xs,) <$> getUniqueDSM++mapForeignTargetOpt :: (CmmExpr -> Opt CmmExpr) -> ForeignTarget -> Opt ForeignTarget+mapForeignTargetOpt exp (ForeignTarget e c) = flip ForeignTarget c <$> exp e+mapForeignTargetOpt _ m@(PrimTarget _) = pure m++wrapRecExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmExpr -> Opt CmmExpr+wrapRecExpOpt f (CmmMachOp op es) = traverse (wrapRecExpOpt f) es >>= f . CmmMachOp op+wrapRecExpOpt f (CmmLoad addr ty align) = wrapRecExpOpt f addr >>= \newAddr -> f (CmmLoad newAddr ty align)+wrapRecExpOpt f e = f e++mapExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmNode e x -> Opt (CmmNode e x)+mapExpOpt _ f@(CmmEntry{}) = pure f+mapExpOpt _ m@(CmmComment _) = pure m+mapExpOpt _ m@(CmmTick _) = pure m+mapExpOpt f (CmmUnwind regs) = CmmUnwind <$> traverse (traverse (traverse f)) regs+mapExpOpt f (CmmAssign r e) = CmmAssign r <$> f e+mapExpOpt f (CmmStore addr e align) = CmmStore <$> f addr <*> f e <*> pure align+mapExpOpt f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall <$> mapForeignTargetOpt f tgt <*> pure fs <*> traverse f as+mapExpOpt _ l@(CmmBranch _) = pure l+mapExpOpt f (CmmCondBranch e ti fi l) = f e >>= \newE -> pure (CmmCondBranch newE ti fi l)+mapExpOpt f (CmmSwitch e ids) = flip CmmSwitch ids <$> f e+mapExpOpt f n@CmmCall {cml_target=tgt} = f tgt >>= \newTgt -> pure n{cml_target = newTgt}+mapExpOpt f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)+ = do+ newTgt <- mapForeignTargetOpt f tgt+ newAs <- traverse f as+ pure $ CmmForeignCall newTgt fs newAs succ ret_args updfr intrbl
compiler/GHC/Cmm/Parser.y view
@@ -1109,7 +1109,10 @@ ( "f2i32", flip MO_FS_Truncate W32 ), ( "f2i64", flip MO_FS_Truncate W64 ), ( "i2f32", flip MO_SF_Round W32 ),- ( "i2f64", flip MO_SF_Round W64 )+ ( "i2f64", flip MO_SF_Round W64 ),++ ( "w2f_bitcast", MO_WF_Bitcast ),+ ( "f2w_bitcast", MO_FW_Bitcast ) ] callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
compiler/GHC/Cmm/Pipeline.hs view
@@ -137,9 +137,12 @@ dump Opt_D_dump_cmm_sp "Layout Stack" g ----------- Sink and inline assignments --------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]- condPass (cmmOptSink cfg) (cmmSink platform) g- Opt_D_dump_cmm_sink "Sink assignments"+ (g, dus) <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+ if cmmOptSink cfg+ then pure $ runUniqueDSM dus $ cmmSink cfg g+ else return (g, dus)+ dump Opt_D_dump_cmm_sink "Sink assignments" g+ ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
compiler/GHC/Cmm/Sink.hs view
@@ -20,6 +20,8 @@ import GHC.Platform import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM+import GHC.Cmm.Config import Data.List (partition) import Data.Maybe@@ -150,9 +152,10 @@ -- y = e2 -- x = e1 -cmmSink :: Platform -> CmmGraph -> CmmGraph-cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks+cmmSink :: CmmConfig -> CmmGraph -> UniqDSM CmmGraph+cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks where+ platform = cmmPlatform cfg liveness = cmmLocalLivenessL platform graph getLive l = mapFindWithDefault emptyLRegSet l liveness @@ -160,11 +163,41 @@ join_pts = findJoinPoints blocks - sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]- sink _ [] = []- sink sunk (b:bs) =- -- pprTrace "sink" (ppr lbl) $- blockJoin first final_middle final_last : sink sunk' bs+ sink :: LabelMap Assignments -> [CmmBlock] -> UniqDSM [CmmBlock]+ sink _ [] = pure []+ sink sunk (b:bs) = do+ -- Now sink and inline in this block+ (prepend, last_fold) <- runOpt cfg $ constantFoldNode last++ (middle', assigs) <- walk cfg (ann_middles ++ annotate platform live_middle prepend) (mapFindWithDefault [] lbl sunk)++ let (final_last, assigs') = tryToInline platform live last_fold assigs+ -- Now, drop any assignments that we will not sink any further.+ (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'+ drop_if :: (LocalReg, CmmExpr, AbsMem)+ -> [LRegSet] -> (Bool, [LRegSet])+ drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')+ where+ should_drop = conflicts platform a final_last+ || not (isTrivial platform rhs) && live_in_multi live_sets r+ || r `elemLRegSet` live_in_joins++ live_sets' | should_drop = live_sets+ | otherwise = map upd live_sets++ upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs+ | otherwise = set++ live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs++ final_middle = foldl' blockSnoc middle' dropped_last++ sunk' = mapUnion sunk $+ mapFromList [ (l, filterAssignments platform (getLive l) assigs'')+ | l <- succs ]++ (blockJoin first final_middle final_last :) <$> sink sunk' bs+ where lbl = entryLabel b (first, middle, last) = blockSplit b@@ -178,11 +211,6 @@ live_middle = gen_killL platform last live ann_middles = annotate platform live_middle (blockToList middle) - -- Now sink and inline in this block- (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk)- fold_last = constantFoldNode platform last- (final_last, assigs') = tryToInline platform live fold_last assigs- -- We cannot sink into join points (successors with more than -- one predecessor), so identify the join points and the set -- of registers live in them.@@ -200,31 +228,6 @@ (_one:_two:_) -> True _ -> False - -- Now, drop any assignments that we will not sink any further.- (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'-- drop_if :: (LocalReg, CmmExpr, AbsMem)- -> [LRegSet] -> (Bool, [LRegSet])- drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')- where- should_drop = conflicts platform a final_last- || not (isTrivial platform rhs) && live_in_multi live_sets r- || r `elemLRegSet` live_in_joins-- live_sets' | should_drop = live_sets- | otherwise = map upd live_sets-- upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs- | otherwise = set-- live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs-- final_middle = foldl' blockSnoc middle' dropped_last-- sunk' = mapUnion sunk $- mapFromList [ (l, filterAssignments platform (getLive l) assigs'')- | l <- succs ]- {- TODO: enable this later, when we have some good tests in place to measure the effect and tune it. @@ -299,7 +302,7 @@ -- * a list of assignments that will be placed *after* that block. -- -walk :: Platform+walk :: CmmConfig -> [(LRegSet, CmmNode O O)] -- nodes of the block, annotated with -- the set of registers live *after* -- this node.@@ -309,36 +312,39 @@ -- Earlier assignments may refer -- to later ones. - -> ( Block CmmNode O O -- The new block- , Assignments -- Assignments to sink further- )+ -> UniqDSM ( Block CmmNode O O -- The new block+ , Assignments -- Assignments to sink further+ ) -walk platform nodes assigs = go nodes emptyBlock assigs+walk cfg nodes assigs = go nodes emptyBlock assigs where- go [] block as = (block, as)+ platform = cmmPlatform cfg+ go [] block as = pure (block, as) go ((live,node):ns) block as -- discard nodes representing dead assignment | shouldDiscard node live = go ns block as- -- sometimes only after simplification we can tell we can discard the node.- -- See Note [Discard simplified nodes]- | noOpAssignment node2 = go ns block as- -- Pick up interesting assignments- | Just a <- shouldSink platform node2 = go ns block (a : as1)- -- Try inlining, drop assignments and move on- | otherwise = go ns block' as'- where- -- Simplify node- node1 = constantFoldNode platform node-- -- Inline assignments- (node2, as1) = tryToInline platform live node1 as-- -- Drop any earlier assignments conflicting with node2- (dropped, as') = dropAssignmentsSimple platform- (\a -> conflicts platform a node2) as1+ | otherwise = do+ (prepend, node1) <- runOpt cfg $ constantFoldNode node+ if not (null prepend)+ then go (annotate platform live (prepend ++ [node1]) ++ ns) block as+ else do+ let -- Inline assignments+ (node2, as1) = tryToInline platform live node1 as+ -- Drop any earlier assignments conflicting with node2+ (dropped, as') = dropAssignmentsSimple platform+ (\a -> conflicts platform a node2) as1+ -- Walk over the rest of the block. Includes dropped assignments+ block' = foldl' blockSnoc block dropped `blockSnoc` node2 - -- Walk over the rest of the block. Includes dropped assignments- block' = foldl' blockSnoc block dropped `blockSnoc` node2+ (prepend2, node3) <- runOpt cfg $ constantFoldNode node2+ if | not (null prepend2) -> go (annotate platform live (prepend2 ++ [node3]) ++ ns) block as+ -- sometimes only after simplification we can tell we can discard the node.+ -- See Note [Discard simplified nodes]+ | noOpAssignment node3 -> go ns block as+ -- Pick up interesting assignments+ | Just a <- shouldSink platform node3 -> go ns block (a : as1)+ -- Try inlining, drop assignments and move on+ | otherwise -> go ns block' as' {- Note [Discard simplified nodes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -23,7 +23,7 @@ import GHC.CmmToAsm.Monad ( NatM, getNewRegNat , getPicBaseMaybeNat, getPlatform, getConfig- , getDebugBlock, getFileId+ , getDebugBlock, getFileId, getThisModuleNat ) -- import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC@@ -896,21 +896,25 @@ CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x- return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))+ `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`- (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+ (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do (reg_x, _format_x, code_x) <- getSomeReg x- return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))+ `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`- (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+ (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32 || w == W64@@ -1471,8 +1475,19 @@ -- Jumps genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock-genJump expr@(CmmLit (CmmLabel lbl))- = return $ unitOL (annExpr expr (J (TLabel lbl)))+genJump expr@(CmmLit (CmmLabel lbl)) = do+ cur_mod <- getThisModuleNat+ !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig+ let is_local = isLocalCLabel cur_mod lbl++ -- We prefer to generate a near jump using a simble `B` instruction+ -- with a range (+/-128MB). But if the target is outside the current module+ -- we might have to account for large code offsets. (#24648)+ if not useFarJumps || is_local+ then return $ unitOL (annExpr expr (J (TLabel lbl)))+ else do+ (target, _format, code) <- getSomeReg expr+ return (code `appOL` unitOL (annExpr expr (J (TReg target)))) genJump expr = do (target, _format, code) <- getSomeReg expr
compiler/GHC/CmmToAsm/Config.hs view
@@ -47,6 +47,7 @@ , ncgDwarfSourceNotes :: !Bool -- ^ Enable GHC-specific source note DIEs , ncgCmmStaticPred :: !Bool -- ^ Enable static control-flow prediction , ncgEnableShortcutting :: !Bool -- ^ Enable shortcutting (don't jump to blocks only containing a jump)+ , ncgEnableInterModuleFarJumps:: !Bool -- ^ Use far-jumps for cross-module jumps. , ncgComputeUnwinding :: !Bool -- ^ Compute block unwinding tables , ncgEnableDeadCodeElimination :: !Bool -- ^ Whether to enable the dead-code elimination }
compiler/GHC/CmmToAsm/RV64/CodeGen.hs view
@@ -1481,7 +1481,7 @@ genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock genJump expr = do (target, _format, code) <- getSomeReg expr- return (code `appOL` unitOL (annExpr expr (B (TReg target))))+ return (code `appOL` unitOL (annExpr expr (J (TReg target)))) -- ----------------------------------------------------------------------------- -- Unconditional branches@@ -2218,5 +2218,6 @@ BCOND {} -> long_bc_jump_size B (TBlock _) -> long_b_jump_size B (TReg _) -> 1+ J op -> instr_size (B op) BL _ _ -> 1 J_TBL {} -> 1
compiler/GHC/CmmToAsm/RV64/Instr.hs view
@@ -97,6 +97,7 @@ ORI dst src1 _ -> usage (regOp src1, regOp dst) XORI dst src1 _ -> usage (regOp src1, regOp dst) J_TBL _ _ t -> usage ([t], [])+ J t -> usage (regTarget t, []) B t -> usage (regTarget t, []) BCOND _ l r t -> usage (regTarget t ++ regOp l ++ regOp r, []) BL t ps -> usage (t : ps, callerSavedRegisters)@@ -195,6 +196,7 @@ ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3) XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3) J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)+ J t -> J (patchTarget t) B t -> B (patchTarget t) BL t ps -> BL (patchReg t) ps BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)@@ -235,6 +237,7 @@ isJumpishInstr instr = case instr of ANN _ i -> isJumpishInstr i J_TBL {} -> True+ J {} -> True B {} -> True BL {} -> True BCOND {} -> True@@ -243,6 +246,7 @@ canFallthroughTo :: Instr -> BlockId -> Bool canFallthroughTo insn bid = case insn of+ J (TBlock target) -> bid == target B (TBlock target) -> bid == target BCOND _ _ _ (TBlock target) -> bid == target J_TBL targets _ _ -> all isTargetBid targets@@ -256,6 +260,7 @@ jumpDestsOfInstr :: Instr -> [BlockId] jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]] jumpDestsOfInstr _ = []@@ -269,6 +274,7 @@ case instr of ANN d i -> ANN d (patchJumpInstr i patchF) J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+ J (TBlock bid) -> J (TBlock (patchF bid)) B (TBlock bid) -> B (TBlock (patchF bid)) BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid)) _ -> panic $ "patchJumpInstr: " ++ instrCon instr@@ -475,7 +481,7 @@ block' = foldr insert_dealloc [] insns insert_dealloc insn r = case insn of- J_TBL {} -> dealloc ++ (insn : r)+ J {} -> dealloc ++ (insn : r) ANN _ e -> insert_dealloc e r _other | jumpDestsOfInstr insn /= [] ->@@ -591,6 +597,8 @@ -- -- @if(o2 cond o3) op <- 1 else op <- 0@ CSET Operand Operand Operand Cond+ -- | Like B, but only used for non-local jumps. Used to distinguish genJumps from others.+ | J Target | -- | A jump instruction with data for switch/jump tables J_TBL [Maybe BlockId] (Maybe CLabel) Reg | -- | Unconditional jump (no linking)@@ -663,6 +671,7 @@ LDRU {} -> "LDRU" CSET {} -> "CSET" J_TBL {} -> "J_TBL"+ J {} -> "J" B {} -> "B" BL {} -> "BL" BCOND {} -> "BCOND"
compiler/GHC/CmmToAsm/RV64/Ppr.hs view
@@ -543,6 +543,7 @@ | otherwise -> op3 (text "\taddi") o1 o2 (OpImm (ImmInt 0)) ORI o1 o2 o3 -> op3 (text "\tori") o1 o2 o3 XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3+ J o1 -> pprInstr platform (B o1) J_TBL _ _ r -> pprInstr platform (B (TReg r)) B l | isLabel l -> line $ text "\tjal" <+> pprOp platform x0 <> comma <+> getLabel platform l B (TReg r) -> line $ text "\tjalr" <+> pprOp platform x0 <> comma <+> pprReg W64 r <> comma <+> text "0"
compiler/GHC/CmmToAsm/Wasm/Asm.hs view
@@ -374,6 +374,7 @@ WasmF32DemoteF64 -> asmTellLine "f32.demote_f64" WasmF64PromoteF32 -> asmTellLine "f64.promote_f32" WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"+ WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt" WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg" WasmMin ty -> asmTellLine $ asmFromWasmType ty <> ".min" WasmMax ty -> asmTellLine $ asmFromWasmType ty <> ".max"
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -438,7 +438,7 @@ lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable" -- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to--- @hs_mulIntMayOflo@ function in @ghc-prim/cbits/mulIntMayOflo@,+-- @hs_mulIntMayOflo@ function in @rts/prim/mulIntMayOflo@, -- otherwise it's quite non-trivial to implement as inline assembly. lower_MO_MulMayOflo :: CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w)@@ -1108,6 +1108,28 @@ x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable" +-- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation.+lower_CMO_Un_Homo_Prim ::+ CLabel ->+ ( forall pre t.+ WasmTypeTag t ->+ WasmInstr+ w+ (t : pre)+ (t : pre)+ ) ->+ WasmTypeTag t ->+ [CmmFormal] ->+ [CmmActual] ->+ WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do+ (ri, _) <- onCmmLocalReg reg+ WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+ pure $+ WasmStatements $+ x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable"+ -- | Lower a binary homogeneous 'CallishMachOp' to a ccall. lower_CMO_Bin_Homo :: CLabel ->@@ -1211,8 +1233,8 @@ lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs-lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs-lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs@@ -1235,8 +1257,8 @@ lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs lower_CallishMachOp lbl MO_F32_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1f" rs xs-lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs-lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs+lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop
compiler/GHC/CmmToAsm/Wasm/Types.hs view
@@ -310,6 +310,7 @@ WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre) WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre) WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+ WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) WasmMax :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1158,7 +1158,7 @@ bitcast :: Format -> Format -> CmmExpr -> NatM Register bitcast fmt rfmt expr = do (src, e_code) <- getSomeReg expr- let code = \dst -> e_code `snocOL` (MOVD fmt (OpReg src) (OpReg dst))+ let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst)) return (Any rfmt code) toI8Reg :: Width -> CmmExpr -> NatM Register@@ -1242,14 +1242,14 @@ (reg, exp) <- getNonClobberedReg expr let fmt = VecFormat len FmtInt64 return $ Any fmt (\dst -> exp `snocOL`- (MOVD II64 (OpReg reg) (OpReg dst)) `snocOL`+ (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL` (PUNPCKLQDQ fmt (OpReg dst) dst) ) vector_int_broadcast len W32 expr = do (reg, exp) <- getNonClobberedReg expr let fmt = VecFormat len FmtInt32 return $ Any fmt (\dst -> exp `snocOL`- (MOVD II32 (OpReg reg) (OpReg dst)) `snocOL`+ (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) ) vector_int_broadcast _ _ _ =@@ -1608,14 +1608,20 @@ -> CmmExpr -> NatM Register vector_float_op_sse op l w expr1 expr2 = do- (reg1, exp1) <- getSomeReg expr1- (reg2, exp2) <- getSomeReg expr2+ -- This function is similar to genTrivialCode, but re-using it would require+ -- handling alignment correctly: SSE vector instructions typically require 16-byte+ -- alignment for their memory operand (this restriction is relaxed with VEX-encoded+ -- instructions).+ -- For now, we always load the value into a register and avoid the alignment issue.+ exp1_code <- getAnyReg expr1+ (reg2, exp2_code) <- getSomeReg expr2 let format = case w of W32 -> VecFormat l FmtFloat W64 -> VecFormat l FmtDouble _ -> pprPanic "Floating-point SSE vector operation not supported at this width" (text "width:" <+> ppr w)- code dst = case op of+ tmp <- getNewRegNat format+ let code dst = case op of VA_Add -> arithInstr ADD VA_Sub -> arithInstr SUB VA_Mul -> arithInstr MUL@@ -1625,9 +1631,13 @@ where -- opcode src2 src1 <==> src1 = src1 `opcode` src2 arithInstr instr- = exp1 `appOL` exp2 `snocOL`- (MOVU format (OpReg reg1) (OpReg dst)) `snocOL`- (instr format (OpReg reg2) (OpReg dst))+ | dst == reg2 = exp2_code `snocOL`+ (MOVU format (OpReg reg2) (OpReg tmp)) `appOL`+ exp1_code dst `snocOL`+ instr format (OpReg tmp) (OpReg dst)+ | otherwise = exp2_code `appOL`+ exp1_code dst `snocOL`+ instr format (OpReg reg2) (OpReg dst) return (Any format code) -------------------- vector_float_extract :: Length@@ -1693,10 +1703,10 @@ let code dst = case lit of CmmInt 0 _ -> exp `snocOL`- (MOVD II64 (OpReg r) (OpReg dst))+ (MOVD fmt II64 (OpReg r) (OpReg dst)) CmmInt 1 _ -> exp `snocOL` (MOVHLPS fmt r tmp) `snocOL`- (MOVD II64 (OpReg tmp) (OpReg dst))+ (MOVD fmt II64 (OpReg tmp) (OpReg dst)) _ -> panic "Error in offset while unpacking" return (Any II64 code) vector_int_extract_sse _ w c e@@ -1914,12 +1924,12 @@ CmmInt 0 _ -> valExp `appOL` vecExp `snocOL` (MOVHLPS fmt vecReg tmp) `snocOL`- (MOVD II64 (OpReg valReg) (OpReg dst)) `snocOL`+ (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL` (PUNPCKLQDQ fmt (OpReg tmp) dst) CmmInt 1 _ -> valExp `appOL` vecExp `snocOL`- (MOV II64 (OpReg vecReg) (OpReg dst)) `snocOL`- (MOVD II64 (OpReg valReg) (OpReg tmp)) `snocOL`+ (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL`+ (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL` (PUNPCKLQDQ fmt (OpReg tmp) dst) _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset) in return $ Any fmt code@@ -3859,7 +3869,7 @@ -- arguments in both fp and integer registers. let (assign_code', regs') | isFloatFormat arg_fmt =- ( assign_code `snocOL` MOVD FF64 (OpReg freg) (OpReg ireg),+ ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg), [ RegWithFormat freg FF64 , RegWithFormat ireg II64 ]) | otherwise = (assign_code, [RegWithFormat ireg II64])@@ -5158,10 +5168,23 @@ W64 | is32Bit -> do let Reg64 dst_hi dst_lo = localReg64 dst RegCode64 vcode rhi rlo <- iselExpr64 src- return $ vcode `appOL`- toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),- MOV II32 (OpReg rhi) (OpReg dst_lo),- BSWAP II32 dst_hi,+ tmp <- getNewRegNat II32+ -- Swap the low and high halves of the register.+ --+ -- NB: if dst_hi == rhi, we must make sure to preserve the contents+ -- of rhi before writing to dst_hi (#25601).+ let shuffle = if dst_hi == rhi && dst_lo == rlo then+ toOL [ MOV II32 (OpReg rhi) (OpReg tmp),+ MOV II32 (OpReg rlo) (OpReg dst_hi),+ MOV II32 (OpReg tmp) (OpReg dst_lo) ]+ else if dst_hi == rhi then+ toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo),+ MOV II32 (OpReg rlo) (OpReg dst_hi) ]+ else+ toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+ MOV II32 (OpReg rhi) (OpReg dst_lo) ]+ return $ vcode `appOL` shuffle `appOL`+ toOL [ BSWAP II32 dst_hi, BSWAP II32 dst_lo ] W16 -> do let dst_r = getLocalRegReg dst
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -39,7 +39,6 @@ , patchJumpInstr , isMetaInstr , isJumpishInstr- , movdOutFormat , MinOrMax(..), MinMaxType(..) ) where@@ -127,11 +126,16 @@ -- with @MOVABS@; we currently do not use this instruction in GHC. -- See https://stackoverflow.com/questions/52434073/whats-the-difference-between-the-x86-64-att-instructions-movq-and-movabsq. - | MOVD Format Operand Operand -- ^ MOVD/MOVQ SSE2 instructions- -- (bitcast between a general purpose- -- register and a float register).- -- Format is input format, output format is- -- calculated in the 'movdOutFormat' function.+ -- | MOVD/MOVQ SSE2 instructions+ -- (bitcast between a general purpose register and a float register).+ | MOVD+ Format -- ^ input format+ Format -- ^ output format+ Operand Operand+ -- NB: MOVD stores both the input and output formats. This is because+ -- neither format fully determines the other, as either might be+ -- a vector format, and we need to know the exact format in order to+ -- correctly spill/unspill. See #25659. | CMOV Cond Format Operand Reg | MOVZxL Format Operand Operand -- ^ The format argument is the size of operand 1 (the number of bits we keep)@@ -372,10 +376,10 @@ -- (largely to avoid partial register stalls) | otherwise -> usageRW fmt src dst- MOVD fmt src dst ->+ MOVD fmt1 fmt2 src dst -> -- NB: MOVD and MOVQ always zero any remaining upper part of destination, -- so the destination is "written" not "modified".- usageRW' fmt (movdOutFormat fmt) src dst+ usageRW' fmt1 fmt2 src dst CMOV _ fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] MOVZxL fmt src dst -> usageRW fmt src dst MOVSxL fmt src dst -> usageRW fmt src dst@@ -636,22 +640,14 @@ interesting _ (RegVirtual _) = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -movdOutFormat :: Format -> Format-movdOutFormat format = case format of- II32 -> FF32- II64 -> FF64- FF32 -> II32- FF64 -> II64- _ -> pprPanic "X86: improper format for movd/movq" (ppr format) - -- | Applies the supplied function to all registers in instructions. -- Typically used to change virtual registers to real registers. patchRegsOfInstr :: HasDebugCallStack => Platform -> Instr -> (Reg -> Reg) -> Instr patchRegsOfInstr platform instr env = case instr of MOV fmt src dst -> MOV fmt (patchOp src) (patchOp dst)- MOVD fmt src dst -> patch2 (MOVD fmt) src dst+ MOVD fmt1 fmt2 src dst -> patch2 (MOVD fmt1 fmt2) src dst CMOV cc fmt src dst -> CMOV cc fmt (patchOp src) (env dst) MOVZxL fmt src dst -> patch2 (MOVZxL fmt) src dst MOVSxL fmt src dst -> patch2 (MOVSxL fmt) src dst
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -76,14 +76,11 @@ let platform = ncgPlatform config top_info_table = topInfoTable proc -- we need a label to delimit the proc code (e.g. in debug builds). When- -- we have an info table, we reuse the info table label. Otherwise we make- -- a fresh "entry" label from the label of the entry block. We can't reuse- -- the entry block label as-is, otherwise we get redundant labels:- -- delimiters for the entry block and for the whole proc are the same (see- -- #22792).+ -- we have an info table, we reuse the info table label. Otherwise we use+ -- the entry label. proc_lbl = case top_info_table of Just (CmmStaticsRaw info_lbl _) -> info_lbl- Nothing -> toProcDelimiterLbl entry_lbl+ Nothing -> entry_lbl -- handle subsections_via_symbols when enabled and when we have an -- info-table to link to. See Note [Subsections Via Symbols]@@ -660,8 +657,8 @@ CMOV cc format src dst -> pprCondOpReg (text "cmov") format cc src dst - MOVD format src dst- -> pprMovdOpOp (text "mov") format src dst+ MOVD format1 format2 src dst+ -> pprMovdOpOp (text "mov") format1 format2 src dst MOVZxL II32 src dst -> pprFormatOpOp (text "mov") II32 src dst@@ -1142,21 +1139,21 @@ pprOperand platform format op2 ] - pprMovdOpOp :: Line doc -> Format -> Operand -> Operand -> doc- pprMovdOpOp name format op1 op2- = let instr = case format of+ pprMovdOpOp :: Line doc -> Format -> Format -> Operand -> Operand -> doc+ pprMovdOpOp name format1 format2 op1 op2+ = let instr = case (format1, format2) of -- bitcasts to/from a general purpose register to a floating point -- register require II32 or II64.- II32 -> text "d"- II64 -> text "q"- FF32 -> text "d"- FF64 -> text "q"- _ -> panic "X86.Ppr.pprMovdOpOp: improper format for movd/movq."+ (II32, _) -> text "d"+ (II64, _) -> text "q"+ (_, II32) -> text "d"+ (_, II64) -> text "q"+ _ -> panic "X86.Ppr.pprMovdOpOp: improper format for movd/movq." in line $ hcat [ char '\t' <> name <> instr <> space,- pprOperand platform format op1,+ pprOperand platform format1 op1, comma,- pprOperand platform (movdOutFormat format) op2+ pprOperand platform format2 op2 ] pprFormatImmRegOp :: Line doc -> Format -> Imm -> Reg -> Operand -> doc
compiler/GHC/CmmToC.hs view
@@ -245,7 +245,7 @@ CmmLit (CmmLabel lbl) | CmmNeverReturns <- ret -> pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"- | not (isMathFun lbl) ->+ | not (isLibcFun lbl) -> pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs _ -> pprCall platform cast_fn cconv hresults hargs <> semi
compiler/GHC/CmmToLlvm.hs view
@@ -11,7 +11,7 @@ ) where -import GHC.Prelude hiding ( head )+import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base@@ -39,8 +39,7 @@ import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ )-import Data.List.NonEmpty ( head )-import Data.Maybe ( fromMaybe, catMaybes )+import Data.Maybe ( fromMaybe, catMaybes, isNothing ) import System.IO -- -----------------------------------------------------------------------------@@ -72,11 +71,13 @@ "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..."- let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X- let major_ver = head . llvmVersionNE $ ver- when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $- "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>- "You are using LLVM version: " <> text (llvmVersionStr ver)++ when (isNothing mb_ver) $ do+ let doWarn = llvmCgDoWarn cfg+ when doWarn $ putMsg logger $+ "Failed to detect LLVM version!" $$+ "Make sure LLVM is installed correctly." $$+ "We will try though..." -- HACK: the Nothing case here is potentially wrong here but we -- currently don't use the LLVM version to guide code generation
compiler/GHC/CmmToLlvm/Base.hs view
@@ -237,7 +237,7 @@ text ") both alive AND mapped to the same real register: " <> ppr real <> text ". This isn't currently supported by the LLVM backend." go (cu@(GlobalRegUse c _):cs) f- | fpr_num c == f = go cs f -- already covered by a real register+ | fpr_num c == f = go cs (f+1) -- already covered by a real register | otherwise = ctor f : go (cu:cs) (f + 1) -- add padding register fpr_ctor :: GlobalRegUse -> Int -> GlobalRegUse@@ -290,7 +290,7 @@ -- the following get cleared for every function (see @withClearVars@) , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type- , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)+ , envStackRegs :: [GlobalRegUse] -- ^ Non-constant registers (alloca'd in the function prelude) } type LlvmEnvMap = UniqFM Unique LlvmType@@ -374,12 +374,14 @@ funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap) -- | Set a register as allocated on the stack-markStackReg :: GlobalReg -> LlvmM ()+markStackReg :: GlobalRegUse -> LlvmM () markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } -- | Check whether a register is allocated on the stack-checkStackReg :: GlobalReg -> LlvmM Bool-checkStackReg r = getEnv ((elem r) . envStackRegs)+checkStackReg :: GlobalReg -> LlvmM (Maybe CmmType)+checkStackReg r = do+ stack_regs <- getEnv envStackRegs+ return $ fmap globalRegUse_type $ lookupRegUse r stack_regs -- | Allocate a new global unnamed metadata identifier getMetaUniqueId :: LlvmM MetaId@@ -524,10 +526,10 @@ modifyEnv $ \env -> env { envAliases = emptyUniqSet } return (concat defss, []) --- | Is a variable one of the special @$llvm@ globals?+-- | Is a variable one of the special @\@llvm@ globals? isBuiltinLlvmVar :: LlvmVar -> Bool isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =- "$llvm" `isPrefixOf` unpackFS lbl+ "llvm." `isPrefixOf` unpackFS lbl isBuiltinLlvmVar _ = False -- | Here we take a global variable definition, rename it with a
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -44,7 +44,7 @@ import qualified Data.Semigroup as Semigroup import Data.List ( nub )-import Data.Maybe ( catMaybes, isJust )+import Data.Maybe ( catMaybes ) type Atomic = Maybe MemoryOrdering type LlvmStatements = OrdList LlvmStatement@@ -201,9 +201,8 @@ return (nilOL, []) genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do- dstV <- getCmmRegW (CmmLocal dst)- let ty = cmmToLlvmType $ localRegType dst- width = widthToLlvmFloat w+ (dstV, ty) <- getCmmRegW (CmmLocal dst)+ let width = widthToLlvmFloat w castV <- lift $ mkLocalVar ty ve <- exprToVarW e statement $ Assignment castV $ Cast LM_Uitofp ve width@@ -254,7 +253,7 @@ let targetTy = widthToLlvmInt width ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) ptrVar <- doExprW (pLift targetTy) ptrExpr- dstVar <- getCmmRegW (CmmLocal dst)+ (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst) let op = case amop of AMO_Add -> LAO_Add AMO_Sub -> LAO_Sub@@ -266,7 +265,7 @@ statement $ Store retVar dstVar Nothing [] genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do- dstV <- getCmmRegW (CmmLocal dst)+ (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst) v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned statement $ Store v1 dstV Nothing [] @@ -278,14 +277,14 @@ let targetTy = getVarType oldVar ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) ptrVar <- doExprW (pLift targetTy) ptrExpr- dstVar <- getCmmRegW (CmmLocal dst)+ (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst) retVar <- doExprW (LMStructU [targetTy,i1]) $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst retVar' <- doExprW targetTy $ ExtractV retVar 0 statement $ Store retVar' dstVar Nothing [] genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do- dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar+ (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst) addrVar <- exprToVarW addr valVar <- exprToVarW val let ptrTy = pLift $ getVarType valVar@@ -351,8 +350,8 @@ retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit -- And extract them into retH. retH <- doExprW width $ Cast LM_Trunc retShifted width- dstRegL <- getCmmRegW (CmmLocal dstL)- dstRegH <- getCmmRegW (CmmLocal dstH)+ (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL)+ (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH) statement $ Store retL dstRegL Nothing [] statement $ Store retH dstRegH Nothing [] @@ -382,9 +381,9 @@ retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1 retC1 <- doExprW i1 $ Compare LM_CMP_Ne retH retH' -- Compare op returns a 1-bit value (i1) retC <- doExprW width $ Cast LM_Zext retC1 width -- so we zero-extend it- dstRegL <- getCmmRegW (CmmLocal dstL)- dstRegH <- getCmmRegW (CmmLocal dstH)- dstRegC <- getCmmRegW (CmmLocal dstC)+ (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL)+ (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH)+ (dstRegC, _dstC_ty) <- getCmmRegW (CmmLocal dstC) statement $ Store retL dstRegL Nothing [] statement $ Store retH dstRegH Nothing [] statement $ Store retC dstRegC Nothing []@@ -419,8 +418,8 @@ let narrow var = doExprW width $ Cast LM_Trunc var width retDiv <- narrow retExtDiv retRem <- narrow retExtRem- dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)- dstRegR <- lift $ getCmmReg (CmmLocal dstR)+ (dstRegQ, _dstQ_ty) <- lift $ getCmmReg (CmmLocal dstQ)+ (dstRegR, _dstR_ty) <- lift $ getCmmReg (CmmLocal dstR) statement $ Store retDiv dstRegQ Nothing [] statement $ Store retRem dstRegR Nothing [] @@ -503,7 +502,6 @@ let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy (llvmFunAlign platform) - argVars <- arg_varsW args_hints ([], nilOL, []) fptr <- getFunPtrW funTy target @@ -523,23 +521,21 @@ ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." let creg = ret_reg res- vreg <- getCmmRegW (CmmLocal creg)- if retTy == pLower (getVarType vreg)- then do- statement $ Store v1 vreg Nothing []- doReturn- else do- let ty = pLower $ getVarType vreg- let op = case ty of- vt | isPointer vt -> LM_Bitcast- | isInt vt -> LM_Ptrtoint- | otherwise ->- panic $ "genCall: CmmReg bad match for"- ++ " returned type!"-- v2 <- doExprW ty $ Cast op v1 ty- statement $ Store v2 vreg Nothing []- doReturn+ (vreg, ty) <- getCmmRegW (CmmLocal creg)+ if retTy == ty+ then do+ statement $ Store v1 vreg Nothing []+ doReturn+ else do+ let op = case ty of+ vt | isPointer vt -> LM_Bitcast+ | isInt vt -> LM_Ptrtoint+ | otherwise ->+ panic $ "genCall: CmmReg bad match for"+ ++ " returned type!"+ v2 <- doExprW ty $ Cast op v1 ty+ statement $ Store v2 vreg Nothing []+ doReturn -- | Generate a call to an LLVM intrinsic that performs arithmetic operation -- with overflow bit (i.e., returns a struct containing the actual result of the@@ -565,8 +561,8 @@ -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects -- both to be i<width>) (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width- dstRegV <- getCmmReg (CmmLocal dstV)- dstRegO <- getCmmReg (CmmLocal dstO)+ (dstRegV, _dstV_ty) <- getCmmReg (CmmLocal dstV)+ (dstRegO, _dstO_ty) <- getCmmReg (CmmLocal dstO) let storeV = Store value dstRegV Nothing [] storeO = Store overflow dstRegO Nothing [] return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)@@ -624,7 +620,7 @@ fname <- cmmPrimOpFunctions op (fptr, _, top3) <- getInstrinct fname width [width] - dstV <- getCmmReg (CmmLocal dst)+ (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) let (_, arg_hints) = foreignTargetHints t let args_hints = zip args arg_hints@@ -656,7 +652,7 @@ fname <- cmmPrimOpFunctions op (fptr, _, top3) <- getInstrinct fname width (const width <$> args) - dstV <- getCmmReg (CmmLocal dst)+ (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) let (_, arg_hints) = foreignTargetHints t let args_hints = zip args arg_hints@@ -1088,11 +1084,9 @@ -- these with registers when possible. genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData genAssign reg val = do- vreg <- getCmmReg reg+ (vreg, ty) <- getCmmReg reg (vval, stmts2, top2) <- exprToVar val let stmts = stmts2-- let ty = (pLower . getVarType) vreg platform <- getPlatform case ty of -- Some registers are pointer types, so need to cast value to pointer@@ -2046,42 +2040,58 @@ -- | Handle CmmReg expression. This will return a pointer to the stack -- location of the register. Throws an error if it isn't allocated on -- the stack.-getCmmReg :: CmmReg -> LlvmM LlvmVar+getCmmReg :: CmmReg -> LlvmM (LlvmVar, LlvmType) getCmmReg (CmmLocal (LocalReg un _)) = do exists <- varLookup un case exists of- Just ety -> return (LMLocalVar un $ pLift ety)+ Just ety -> return (LMLocalVar un $ pLift ety, ety) Nothing -> pprPanic "getCmmReg: Cmm register " $ ppr un <> text " was not allocated!" -- This should never happen, as every local variable should -- have been assigned a value at some point, triggering -- "funPrologue" to allocate it on the stack. -getCmmReg (CmmGlobal ru@(GlobalRegUse r _))- = do onStack <- checkStackReg r+getCmmReg (CmmGlobal (GlobalRegUse reg _reg_ty))+ = do onStack <- checkStackReg reg platform <- getPlatform- if onStack- then return (lmGlobalRegVar platform ru)- else pprPanic "getCmmReg: Cmm register " $- ppr r <> text " not stack-allocated!"+ case onStack of+ Just stack_ty -> do+ let var = lmGlobalRegVar platform (GlobalRegUse reg stack_ty)+ return (var, pLower $ getVarType var)+ Nothing ->+ pprPanic "getCmmReg: Cmm register " $+ ppr reg <> text " not stack-allocated!" -- | Return the value of a given register, as well as its type. Might -- need to be load from stack. getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) getCmmRegVal reg = case reg of- CmmGlobal g -> do- onStack <- checkStackReg (globalRegUse_reg g)+ CmmGlobal gu@(GlobalRegUse g _) -> do+ onStack <- checkStackReg g platform <- getPlatform- if onStack then loadFromStack else do- let r = lmGlobalRegArg platform g- return (r, getVarType r, nilOL)+ case onStack of+ Just {} ->+ loadFromStack+ Nothing -> do+ let r = lmGlobalRegArg platform gu+ return (r, getVarType r, nilOL) _ -> loadFromStack- where loadFromStack = do- ptr <- getCmmReg reg- let ty = pLower $ getVarType ptr- (v, s) <- doExpr ty (Load ptr Nothing)- return (v, ty, unitOL s)+ where+ loadFromStack = do+ platform <- getPlatform+ (ptr, stack_reg_ty) <- getCmmReg reg+ let reg_ty = case reg of+ CmmGlobal g -> pLower $ getVarType $ lmGlobalRegVar platform g+ CmmLocal {} -> stack_reg_ty+ if reg_ty /= stack_reg_ty+ then do+ (v1, s1) <- doExpr stack_reg_ty (Load ptr Nothing)+ (v2, s2) <- doExpr reg_ty (Cast LM_Bitcast v1 reg_ty)+ return (v2, reg_ty, toOL [s1, s2])+ else do+ (v, s) <- doExpr reg_ty (Load ptr Nothing)+ return (v, reg_ty, unitOL s) -- | Allocate a local CmmReg on the stack allocReg :: CmmReg -> (LlvmVar, LlvmStatements)@@ -2207,15 +2217,29 @@ let (newv, stmts) = allocReg reg varInsert un (pLower $ getVarType newv) return stmts- CmmGlobal ru@(GlobalRegUse r _) -> do+ CmmGlobal ru@(GlobalRegUse r ty0) -> do let reg = lmGlobalRegVar platform ru- arg = lmGlobalRegArg platform ru ty = (pLower . getVarType) reg trash = LMLitVar $ LMUndefLit ty- rval = if isJust (mbLive r) then arg else trash+ rval = case mbLive r of+ Just (GlobalRegUse _ ty') ->+ lmGlobalRegArg platform (GlobalRegUse r ty')+ _ -> trash alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1- markStackReg r- return $ toOL [alloc, Store rval reg Nothing []]+ markStackReg ru+ case mbLive r of+ Just (GlobalRegUse _ ty')+ | let llvm_ty = cmmToLlvmType ty0+ llvm_ty' = cmmToLlvmType ty'+ , llvm_ty /= llvm_ty'+ -> do castV <- mkLocalVar (pLift llvm_ty')+ return $+ toOL [ alloc+ , Assignment castV $ Cast LM_Bitcast reg (pLift llvm_ty')+ , Store rval castV Nothing []+ ]+ _ ->+ return $ toOL [alloc, Store rval reg Nothing []] return (concatOL stmtss `snocOL` jumpToEntry, []) where@@ -2380,7 +2404,7 @@ LlvmAccum stmts decls <- execWriterT action return (stmts, decls) -getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM (LlvmVar, LlvmType) getCmmRegW = lift . getCmmReg genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar
compiler/GHC/CmmToLlvm/Data.hs view
@@ -124,7 +124,7 @@ prio = LMStaticLit $ LMIntLit 0xffff i32 in LMStaticStrucU [prio, fn, null] entry_ty - arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+ arr_var = LMGlobalVar var_nm arr_ty Appending Nothing Nothing Global mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8] arr_ty = LMArray (length clbls) entry_ty
compiler/GHC/Core/LateCC/OverloadedCalls.hs view
@@ -20,7 +20,6 @@ import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Utils-import GHC.Tc.Utils.TcType import GHC.Types.Id import GHC.Types.Name import GHC.Types.SrcLoc@@ -30,6 +29,41 @@ type OverloadedCallsCCState = Strict.Maybe SrcSpan +{- Note [Overloaded Calls and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently GHC considers cost centres as destructive to+join contexts. Or in other words this is not considered valid:++ join f x = ...+ in+ ... -> scc<tick> jmp++This makes the functionality of `-fprof-late-overloaded-calls` not feasible+for join points in general. We used to try to work around this by putting the+ticks on the rhs of the join point rather than around the jump. However beyond+the loss of accuracy this was broken for recursive join points as we ended up+with something like:++ rec-join f x = scc<tick> ... jmp f x++Which similarly is not valid as the tick once again destroys the tail call.+One might think we could limit ourselves to non-recursive tail calls and do+something clever like:++ join f x = scc<tick> ...+ in ... jmp f x++And sometimes this works! But sometimes the full rhs would look something like:++ join g x = ....+ join f x = scc<tick> ... -> jmp g x++Which, would again no longer be valid. I believe in the long run we can make+cost centre ticks non-destructive to join points. Or we could keep track of+where we are/are not allowed to insert a cost centre. But in the short term I will+simply disable the annotation of join calls under this flag.+-}+ -- | Insert cost centres on function applications with dictionary arguments. The -- source locations attached to the cost centres is approximated based on the -- "closest" source note encountered in the traversal.@@ -53,21 +87,10 @@ CoreBndr -> LateCCM OverloadedCallsCCState CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr- wrap_if_join b pexpr = do+ wrap_if_join _b pexpr = do+ -- See Note [Overloaded Calls and join points] expr <- pexpr- if isJoinId b && isOverloadedTy (exprType expr) then do- let- cc_name :: FastString- cc_name = fsLit "join-rhs-" `appendFS` getOccFS b-- cc_srcspan <-- fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $- lift $ gets lateCCState_extra-- insertCC cc_name cc_srcspan expr- else- return expr-+ return expr processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr processExpr expr =@@ -100,6 +123,7 @@ -- Avoid instrumenting join points. -- (See comment in processBind above)+ -- Also see Note [Overloaded Calls and join points] && not (isJoinVarExpr f) then do -- Extract a name and source location from the function being
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-} -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate@@ -22,12 +23,15 @@ import GHC.Types.Cpr import GHC.Types.Unique.MemoFun +import GHC.Core import GHC.Core.FamInstEnv import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Utils-import GHC.Core+import GHC.Core.Coercion+import GHC.Core.Reduction import GHC.Core.Seq+import GHC.Core.TyCon import GHC.Core.Opt.WorkWrap.Utils import GHC.Data.Graph.UnVar -- for UnVarSet@@ -216,9 +220,13 @@ cprAnal' _ (Coercion co) = (topCprType, Coercion co) cprAnal' env (Cast e co)- = (cpr_ty, Cast e' co)+ = (cpr_ty', Cast e' co) where (cpr_ty, e') = cprAnal env e+ cpr_ty'+ | cpr_ty == topCprType = topCprType -- cheap case first+ | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors]+ | otherwise = cpr_ty cprAnal' env (Tick t e) = (cpr_ty, Tick t e')@@ -384,6 +392,19 @@ mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 +isRecNewTyConApp :: AnalEnv -> Type -> Bool+-- See Note [CPR for recursive newtype constructors]+isRecNewTyConApp env ty+ --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined+ | Just (tc, tc_args) <- splitTyConApp_maybe ty =+ if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args+ -> isRecNewTyConApp env rhs+ | Just dc <- newTyConDataCon_maybe tc+ -> ae_rec_dc env dc == DefinitelyRecursive+ | otherwise+ -> False+ | otherwise = False+ -- -- * Bindings --@@ -407,12 +428,18 @@ | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + -- If fixed-point iteration does not yield a result we use this instead+ -- See Note [Safe abortion in the fixed-point iteration]+ abort :: (AnalEnv, [(Id,CoreExpr)])+ abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ]+ -- The fixed-point varies the idCprSig field of the binders and and their -- entries in the AnalEnv, and terminates if that annotation does not change -- any more. loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) loop n env pairs | found_fixpoint = (reset_env', pairs')+ | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort | otherwise = loop (n+1) env' pairs' where -- In all but the first iteration, delete the virgin flag@@ -511,8 +538,9 @@ -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks]- | stays_thunk = trimCprTy rhs_ty- | otherwise = rhs_ty+ | rhs_ty == topCprType = topCprType -- cheap case first+ | stays_thunk = trimCprTy rhs_ty+ | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' -- See Note [OPAQUE pragma]@@ -631,7 +659,7 @@ , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. , ae_rec_dc :: DataCon -> IsRecDataConResult- -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'+ -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType } instance Outputable AnalEnv where@@ -1034,10 +1062,11 @@ What can we do about it? - A. Don't CPR functions that return a *recursive data type* (the list in this- case). This is the solution we adopt. Rationale: the benefit of CPR on- recursive data structures is slight, because it only affects the outer layer- of a potentially massive data structure.+ A. Don't give recursive data constructors or casts representing recursive newtype constructors+ the CPR property (the list in this case). This is the solution we adopt.+ Rationale: the benefit of CPR on recursive data structures is slight,+ because it only affects the outer layer of a potentially massive data+ structure. B. Don't CPR any *recursive function*. That would be quite conservative, as it would also affect e.g. the factorial function. C. Flat CPR only for recursive functions. This prevents the asymptotic@@ -1047,11 +1076,16 @@ `c` in the second eqn of `replicateC`). But we'd need to know which paths were hot. We want such static branch frequency estimates in #20378. -We adopt solution (A) It is ad-hoc, but appears to work reasonably well.-Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:-See Note [Detecting recursive data constructors]. We don't have to be perfect-and can simply keep on unboxing if unsure.+We adopt solution (A). It is ad-hoc, but appears to work reasonably well.+Specifically: +* For data constructors, in `cprTransformDataConWork` we check for a recursive+ data constructor by calling `ae_rec_dc env`, which is just a memoised version+ of `isRecDataCon`. See Note [Detecting recursive data constructors]+* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype+ by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`.+ See Note [CPR for recursive newtype constructors]+ Note [Detecting recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What qualifies as a "recursive data constructor" as per@@ -1067,12 +1101,15 @@ types of its data constructors and check `tc_args` for recursion. C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to `rhs`, look into the `rhs` type.+ D. If `ty = f a`, then look into `f` and `a`+ E. If `ty = ty' |> co`, then look into `ty'` A few perhaps surprising points: 1. It deems any function type as non-recursive, because it's unlikely that a recursion through a function type builds up a recursive data structure.- 2. It doesn't look into kinds or coercion types because there's nothing to unbox.+ 2. It doesn't look into kinds, literals or coercion types because we are+ ultimately looking for value-level recursion. Same for promoted data constructors. 3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not; we simply look at its definition/DataCons and its field tys and look for@@ -1144,6 +1181,22 @@ I've played with the idea to make points (1) through (3) of 'isRecDataCon' configurable like (4) to enable more re-use throughout the compiler, but haven't found a killer app for that yet, so ultimately didn't do that.++Note [CPR for recursive newtype constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A newtype constructor is considered recursive iff the data constructor of the+equivalent datatype definition is recursive.+See Note [CPR for recursive data constructors].+Detection is a bit complicated by the fact that newtype constructor applications+reflect as Casts in Core:++ newtype List a = C (Maybe (a, List a))+ xs = C (Just (0, C Nothing))+ ==> {desugar to Core}+ xs = Just (0, Nothing |> sym N:List) |> sym N:List++So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than+in `cprTransformDataConWork` as for data constructors. Note [CPR examples] ~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -63,6 +63,7 @@ import GHC.Types.RepType import GHC.Unit.Types+import GHC.Core.TyCo.Rep {- ************************************************************************@@ -1426,23 +1427,29 @@ | arg_ty <- map scaledThing (dataConRepArgTys dc) ] go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult- go_arg_ty fuel visited_tcs ty- --- | pprTrace "arg_ty" (ppr ty) False = undefined+ go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $+ case coreFullView ty of+ TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args+ -- See Note [Detecting recursive data constructors], points (B) and (C) - | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty- = go_arg_ty fuel visited_tcs ty'+ ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty' -- See Note [Detecting recursive data constructors], point (A) - | Just (tc, tc_args) <- splitTyConApp_maybe ty- = go_tc_app fuel visited_tcs tc tc_args+ CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' - | otherwise- = NonRecursiveOrUnsure+ AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a+ -- See Note [Detecting recursive data constructors], point (D) + FunTy{} -> NonRecursiveOrUnsure+ -- See Note [Detecting recursive data constructors], point (1)++ -- (TyVarTy{} | LitTy{} | CastTy{})+ _ -> NonRecursiveOrUnsure+ go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult go_tc_app fuel visited_tcs tc tc_args = case tyConDataCons_maybe tc of- --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined+ ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args -- This is the only place where we look at tc_args, which might have -- See Note [Detecting recursive data constructors], point (C) and (5)
compiler/GHC/CoreToStg/Prep.hs view
@@ -2218,6 +2218,7 @@ is_hnf = exprIsHNF rhs dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd+ ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs -- See Note [Controlling Speculative Evaluation] call_ok_for_spec x
compiler/GHC/Driver/Config/Cmm.hs view
@@ -24,5 +24,17 @@ , cmmDoCmmSwitchPlans = not (backendHasNativeSwitch (backend dflags)) , cmmSplitProcPoints = not (backendSupportsUnsplitProcPoints (backend dflags)) || not (platformTablesNextToCode platform)+ , cmmAllowMul2 = (ncg && x86ish) || llvm+ , cmmOptConstDivision = not llvm } where platform = targetPlatform dflags+ -- Copied from StgToCmm+ (ncg, llvm) = case backendPrimitiveImplementation (backend dflags) of+ GenericPrimitives -> (False, False)+ NcgPrimitives -> (True, False)+ LlvmPrimitives -> (False, True)+ JSPrimitives -> (False, False)+ x86ish = case platformArch platform of+ ArchX86 -> True+ ArchX86_64 -> True+ _ -> False
compiler/GHC/Driver/Config/CmmToAsm.hs view
@@ -70,6 +70,7 @@ , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags+ , ncgEnableInterModuleFarJumps = gopt Opt_InterModuleFarJumps dflags , ncgComputeUnwinding = debugLevel dflags > 0 , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags) -- Disable when -finfo-table-map is on (#20428)
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -409,7 +409,7 @@ let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_env = hsc_unit_env hsc_env- let home_unit = hsc_home_unit hsc_env+ let home_unit = hsc_home_unit_maybe hsc_env let tmpfs = hsc_tmpfs hsc_env let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc@@ -508,10 +508,12 @@ -- These symbols are imported into the stub.c file via RtsAPI.h, and the -- way we do the import depends on whether we're currently compiling -- the base package or not.- ++ (if platformOS platform == OSMinGW32 &&- isHomeUnitId home_unit ghcInternalUnitId- then [ "-DCOMPILING_GHC_INTERNAL_PACKAGE" ]- else [])+ ++ (case home_unit of+ Just hu+ | isHomeUnitId hu ghcInternalUnitId+ , platformOS platform == OSMinGW32+ -> ["-DCOMPILING_BASE_PACKAGE"]+ _ -> []) -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
compiler/GHC/HsToCore/Binds.hs view
@@ -1584,14 +1584,14 @@ | Just (t1,t2) <- splitAppTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2- ; mkTrApp <- dsLookupGlobalId mkTrAppName- -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).- -- TypeRep a -> TypeRep b -> TypeRep (a b)+ ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName+ -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+ -- TypeRep a -> TypeRep b -> TypeRep (a b) ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, -- since it's a kind- ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])+ ; let expr = mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ]) [ e1, e2 ]- -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr+ -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr ; return expr }
compiler/GHC/HsToCore/Foreign/C.hs view
@@ -515,11 +515,10 @@ , text "rts_inCall" <> parens ( char '&' <> cap <> text "rts_apply" <> parens (- cap <>- text "(HaskellObj)"+ cap <> (if is_IO_res_ty- then text "runIO_closure"- else text "runNonIO_closure")+ then text "ghc_hs_iface->runIO_closure"+ else text "ghc_hs_iface->runNonIO_closure") <> comma <> expr_to_run ) <+> comma
compiler/GHC/HsToCore/Foreign/Wasm.hs view
@@ -11,6 +11,7 @@ ( intercalate, stripPrefix, )+import Data.List qualified import Data.Maybe import GHC.Builtin.Names import GHC.Builtin.Types@@ -46,6 +47,9 @@ import GHC.Utils.Panic import Language.Haskell.Syntax.Basic +data Synchronicity = Sync | Async+ deriving (Eq)+ dsWasmJSImport :: Id -> Coercion ->@@ -53,10 +57,15 @@ Safety -> DsM ([Binding], CHeader, CStub, [Id]) dsWasmJSImport id co (CFunction (StaticTarget _ js_src mUnitId _)) safety- | js_src == "wrapper" = dsWasmJSDynamicExport id co mUnitId+ | js_src == "wrapper" = dsWasmJSDynamicExport Async id co mUnitId+ | js_src == "wrapper sync" = dsWasmJSDynamicExport Sync id co mUnitId | otherwise = do- (bs, h, c) <- dsWasmJSStaticImport id co (unpackFS js_src) mUnitId safety+ (bs, h, c) <- dsWasmJSStaticImport id co (unpackFS js_src) mUnitId sync pure (bs, h, c, [])+ where+ sync = case safety of+ PlayRisky -> Sync+ _ -> Async dsWasmJSImport _ _ _ _ = panic "dsWasmJSImport: unreachable" {-@@ -77,17 +86,24 @@ mk_wrapper_worker :: StablePtr HsFuncType -> HsFuncType mk_wrapper_worker sp = unsafeDupablePerformIO (deRefStablePtr sp) -No need to bother with eta-expansion here. Also, the worker function-is marked as a JSFFI static export.+The worker function is marked as a JSFFI static export. It turns a+dynamic export to a static one by prepending a StablePtr to the+argument list. +We don't actually generate a Core binding for the worker function+though; the JSFFI static export C stub generation logic would just+generate a function that doesn't need to refer to the worker Id's+closure. This is not just for convenience, it's actually required for+correctness, see #25473.+ 2. The adjustor function foreign import javascript unsafe "(...args) => __exports.mk_wrapper_worker($1, ...args)" mk_wrapper_adjustor :: StablePtr HsFuncType -> IO JSVal -It generates a JavaScript callback that captures the stable pointer.-When the callback is invoked later, it calls our worker function and-passes the stable pointer as well as the rest of the arguments.+Now that mk_wrapper_worker is exported in __exports, we need to make a+JavaScript callback that invokes mk_wrapper_worker with the right+StablePtr as well as the rest of the arguments. 3. The wrapper function @@ -102,43 +118,47 @@ exports, it's set to the Haskell function's stable pointer. This way, when we call freeJSVal, the Haskell function can be freed as well. +By default, JSFFI exports are async JavaScript functions. One can use+"wrapper sync" instead of "wrapper" to indicate the Haskell function+is meant to be exported as a sync JavaScript function. All the+comments above still hold, with only only difference:+mk_wrapper_worker is exported as a sync function. See+Note [Desugaring JSFFI static export] for further details.+ -} dsWasmJSDynamicExport ::- Id -> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])-dsWasmJSDynamicExport fn_id co mUnitId = do+ Synchronicity ->+ Id ->+ Coercion ->+ Maybe Unit ->+ DsM ([Binding], CHeader, CStub, [Id])+dsWasmJSDynamicExport sync fn_id co mUnitId = do sp_tycon <- dsLookupTyCon stablePtrTyConName let ty = coercionLKind co (tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty ([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty sp_ty = mkTyConApp sp_tycon [arg_ty]- (real_arg_tys, _) = tcSplitFunTys arg_ty sp_id <- newSysLocalMDs sp_ty- work_uniq <- newUnique- work_export_name <- uniqueCFunName- deRefStablePtr_id <- lookupGhcInternalVarId "GHC.Internal.Stable" "deRefStablePtr"+ work_export_name <- unpackFS <$> uniqueCFunName+ deRefStablePtr_id <-+ lookupGhcInternalVarId+ "GHC.Internal.Stable"+ "deRefStablePtr" unsafeDupablePerformIO_id <- lookupGhcInternalVarId "GHC.Internal.IO.Unsafe" "unsafeDupablePerformIO"- let work_id =- mkExportedVanillaId- ( mkExternalName- work_uniq- (nameModule $ getName fn_id)- (mkVarOcc $ "jsffi_" ++ occNameString (getOccName fn_id) ++ "_work")- generatedSrcSpan- )- work_ty- work_rhs =+ let work_rhs = mkCoreLams ([tv | Bndr tv _ <- tv_bndrs] ++ [sp_id]) $ mkApps (Var unsafeDupablePerformIO_id) [Type arg_ty, mkApps (Var deRefStablePtr_id) [Type arg_ty, Var sp_id]] work_ty = exprType work_rhs (work_h, work_c, _, work_ids, work_bs) <-- dsWasmJSExport- work_id+ dsWasmJSExport'+ sync+ Nothing (mkRepReflCo work_ty) work_export_name adjustor_uniq <- newUnique@@ -157,21 +177,18 @@ adjustor_ty adjustor_ty = mkForAllTys tv_bndrs $ mkVisFunTysMany [sp_ty] io_jsval_ty adjustor_js_src =- "("- ++ intercalate "," ["a" ++ show i | i <- [1 .. length real_arg_tys]]- ++ ") => __exports."- ++ unpackFS work_export_name- ++ "($1"- ++ mconcat [",a" ++ show i | i <- [1 .. length real_arg_tys]]- ++ ")"+ "(...args) => __exports." ++ work_export_name ++ "($1, ...args)" (adjustor_bs, adjustor_h, adjustor_c) <- dsWasmJSStaticImport adjustor_id (mkRepReflCo adjustor_ty) adjustor_js_src mUnitId- PlayRisky- mkJSCallback_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "mkJSCallback"+ Sync+ mkJSCallback_id <-+ lookupGhcInternalVarId+ "GHC.Internal.Wasm.Prim.Exports"+ "mkJSCallback" let wrap_rhs = mkCoreLams [tv | Bndr tv _ <- tv_bndrs] $ mkApps@@ -182,7 +199,7 @@ [Type $ mkTyVarTy tv | Bndr tv _ <- tv_bndrs] ] pure- ( [(fn_id, Cast wrap_rhs co), (work_id, work_rhs)] ++ work_bs ++ adjustor_bs,+ ( [(fn_id, Cast wrap_rhs co)] ++ work_bs ++ adjustor_bs, work_h `mappend` adjustor_h, work_c `mappend` adjustor_c, work_ids@@ -194,7 +211,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The simplest case is JSFFI sync import, those marked as unsafe. It is-implemented on top of C FFI unsafe import.+implemented on top of C FFI safe import. Unlike C FFI which generates a worker/wrapper pair that unboxes the arguments and boxes the result in Haskell, we only desugar to a single@@ -202,10 +219,11 @@ evaluated, then passes the boxed arguments directly to C and receive the boxed result from C as well. -This is of course less efficient than how C FFI does it, and unboxed-FFI types aren't supported, but it's the easiest way to implement it,+This is slightly less efficient than how C FFI does it, and unboxed+FFI types aren't supported, but it's the simplest way to implement it, especially since leaving all the boxing/unboxing business to C unifies-the implementation of JSFFI imports and exports.+the implementation of JSFFI imports and exports+(rts_mkJSVal/rts_getJSVal). Now, each sync import calls a generated C function with a unique symbol. The C function uses rts_get* to unbox the arguments, call into@@ -240,6 +258,14 @@ generating a C stub, so we need to smuggle the assembly code into C via __asm__. +The C FFI import that calls the generated C function is always marked+as safe. There is some extra overhead, but this allows re-entrance by+Haskell -> JavaScript -> Haskell function calls with each call being a+synchronous one. It's possible to steal the "interruptible" keyword to+indicate async imports, "safe" for sync imports and "unsafe" for sync+imports sans the safe C FFI overhead, but it's simply not worth the+extra complexity.+ JSFFI async import is implemented on top of JSFFI sync import. We still desugar it to a single Haskell binding that calls C, with some subtle differences:@@ -250,12 +276,6 @@ "($1, $2)". As you can see, it is the arrow function binder, and the post-linker will respect the async binder and allow await in the function body.-- The C import is also marked as safe. This is required since the- JavaScript code may re-enter Haskell. If re-entrance only happens in- future event loop tasks, it's fine to mark the C import as unsafe- since the current Haskell execution context has already been freed- at that point, but there's no such guarantee, so better safe than- sorry here. Now we have the Promise JSVal, we apply stg_blockPromise to it to get a thunk with the desired return type. When the thunk is forced, it@@ -270,9 +290,9 @@ Coercion -> String -> Maybe Unit ->- Safety ->+ Synchronicity -> DsM ([Binding], CHeader, CStub)-dsWasmJSStaticImport fn_id co js_src' mUnitId safety = do+dsWasmJSStaticImport fn_id co js_src' mUnitId sync = do cfun_name <- uniqueCFunName let ty = coercionLKind co (tvs, fun_ty) = tcSplitForAllInvisTyVars ty@@ -289,36 +309,31 @@ ++ ")" | otherwise = js_src'- case safety of- PlayRisky -> do- rhs <-- importBindingRHS- mUnitId- PlayRisky- cfun_name- tvs- arg_tys- orig_res_ty- id+ case sync of+ Sync -> do+ rhs <- importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty id pure ( [(fn_id, Cast rhs co)], CHeader commonCDecls,- importCStub- PlayRisky- cfun_name- (map scaledThing arg_tys)- res_ty- js_src+ importCStub Sync cfun_name (map scaledThing arg_tys) res_ty js_src )- _ -> do+ Async -> do+ err_msg <- mkStringExpr $ js_src io_tycon <- dsLookupTyCon ioTyConName- jsval_ty <- mkTyConTy <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal"+ jsval_ty <-+ mkTyConTy+ <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal" bindIO_id <- dsLookupGlobalId bindIOName returnIO_id <- dsLookupGlobalId returnIOName promise_id <- newSysLocalMDs jsval_ty- blockPromise_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" "stg_blockPromise"+ blockPromise_id <-+ lookupGhcInternalVarId+ "GHC.Internal.Wasm.Prim.Imports"+ "stg_blockPromise" msgPromise_id <-- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" $ "stg_messagePromise" ++ ffiType res_ty+ lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports"+ $ "stg_messagePromise"+ ++ ffiType res_ty unsafeDupablePerformIO_id <- lookupGhcInternalVarId "GHC.Internal.IO.Unsafe"@@ -326,7 +341,6 @@ rhs <- importBindingRHS mUnitId- PlaySafe cfun_name tvs arg_tys@@ -350,19 +364,14 @@ [ Type res_ty, mkApps (Var blockPromise_id)- [Type res_ty, Var promise_id, Var msgPromise_id]+ [Type res_ty, err_msg, Var promise_id, Var msgPromise_id] ] ] ) pure ( [(fn_id, Cast rhs co)], CHeader commonCDecls,- importCStub- PlaySafe- cfun_name- (map scaledThing arg_tys)- jsval_ty- js_src+ importCStub Async cfun_name (map scaledThing arg_tys) jsval_ty js_src ) uniqueCFunName :: DsM FastString@@ -372,92 +381,91 @@ importBindingRHS :: Maybe Unit ->- Safety -> FastString -> [TyVar] -> [Scaled Type] -> Type -> (CoreExpr -> CoreExpr) -> DsM CoreExpr-importBindingRHS mUnitId safety cfun_name tvs arg_tys orig_res_ty res_trans =- do- ccall_uniq <- newUnique- args_unevaled <- newSysLocalsDs arg_tys- args_evaled <- newSysLocalsDs arg_tys- -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #)- -- res_wrapper: turn the_call to (IO a) or a- (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of- Just (io_tycon, res_ty) -> do- s0_id <- newSysLocalMDs realWorldStatePrimTy- s1_id <- newSysLocalMDs realWorldStatePrimTy- let io_data_con = tyConSingleDataCon io_tycon- toIOCon = dataConWorkId io_data_con- (ccall_res_ty, wrap)- | res_ty `eqType` unitTy =- ( mkTupleTy Unboxed [realWorldStatePrimTy],- \the_call ->- mkApps- (Var toIOCon)- [ Type res_ty,- Lam s0_id- $ mkWildCase- (App the_call (Var s0_id))- (unrestricted ccall_res_ty)- (mkTupleTy Unboxed [realWorldStatePrimTy, unitTy])- [ Alt- (DataAlt (tupleDataCon Unboxed 1))- [s1_id]- (mkCoreUnboxedTuple [Var s1_id, unitExpr])- ]- ]- )- | otherwise =- ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty],- \the_call -> mkApps (Var toIOCon) [Type res_ty, the_call]- )- pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)- Nothing -> do- unsafeDupablePerformIO_id <-- lookupGhcInternalVarId- "GHC.Internal.IO.Unsafe"- "unsafeDupablePerformIO"- io_data_con <- dsLookupDataCon ioDataConName- let ccall_res_ty =- mkTupleTy Unboxed [realWorldStatePrimTy, orig_res_ty]- toIOCon = dataConWorkId io_data_con- wrap the_call =- mkApps- (Var unsafeDupablePerformIO_id)- [ Type orig_res_ty,- mkApps (Var toIOCon) [Type orig_res_ty, the_call]- ]- pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)- let cfun_fcall =- CCall- ( CCallSpec- (StaticTarget NoSourceText cfun_name mUnitId True)- CCallConv- safety- )- call_app =- mkFCall ccall_uniq cfun_fcall (map Var args_evaled) ccall_action_ty- rhs =- mkCoreLams (tvs ++ args_unevaled)- $ foldr- (\(arg_u, arg_e) acc -> mkDefaultCase (Var arg_u) arg_e acc)- -- res_trans transforms the result. When desugaring- -- JSFFI sync imports, the result is just (IO a) or a,- -- and res_trans is id; for async cases, the result is- -- always (IO JSVal), and res_trans will wrap it in a- -- thunk that has the original return type. This way, we- -- can reuse most of the RHS generation logic for both- -- sync/async imports.- (res_trans $ res_wrapper call_app)- (zip args_unevaled args_evaled)- pure rhs+importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty res_trans = do+ ccall_uniq <- newUnique+ args_unevaled <- newSysLocalsDs arg_tys+ args_evaled <- newSysLocalsDs arg_tys+ -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #)+ -- res_wrapper: turn the_call to (IO a) or a+ (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of+ Just (io_tycon, res_ty) -> do+ s0_id <- newSysLocalMDs realWorldStatePrimTy+ s1_id <- newSysLocalMDs realWorldStatePrimTy+ let io_data_con = tyConSingleDataCon io_tycon+ toIOCon = dataConWorkId io_data_con+ (ccall_res_ty, wrap)+ | res_ty `eqType` unitTy =+ ( mkTupleTy Unboxed [realWorldStatePrimTy],+ \the_call ->+ mkApps+ (Var toIOCon)+ [ Type res_ty,+ Lam s0_id+ $ mkWildCase+ (App the_call (Var s0_id))+ (unrestricted ccall_res_ty)+ (mkTupleTy Unboxed [realWorldStatePrimTy, unitTy])+ [ Alt+ (DataAlt (tupleDataCon Unboxed 1))+ [s1_id]+ (mkCoreUnboxedTuple [Var s1_id, unitExpr])+ ]+ ]+ )+ | otherwise =+ ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty],+ \the_call -> mkApps (Var toIOCon) [Type res_ty, the_call]+ )+ pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)+ Nothing -> do+ unsafeDupablePerformIO_id <-+ lookupGhcInternalVarId+ "GHC.Internal.IO.Unsafe"+ "unsafeDupablePerformIO"+ io_data_con <- dsLookupDataCon ioDataConName+ let ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, orig_res_ty]+ toIOCon = dataConWorkId io_data_con+ wrap the_call =+ mkApps+ (Var unsafeDupablePerformIO_id)+ [ Type orig_res_ty,+ mkApps (Var toIOCon) [Type orig_res_ty, the_call]+ ]+ pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)+ let cfun_fcall =+ CCall+ ( CCallSpec+ (StaticTarget NoSourceText cfun_name mUnitId True)+ CCallConv+ -- Same even for foreign import javascript unsafe, for+ -- the sake of re-entrancy.+ PlaySafe+ )+ call_app =+ mkFCall ccall_uniq cfun_fcall (map Var args_evaled) ccall_action_ty+ rhs =+ mkCoreLams (tvs ++ args_unevaled)+ $ foldr+ (\(arg_u, arg_e) acc -> mkDefaultCase (Var arg_u) arg_e acc)+ -- res_trans transforms the result. When desugaring+ -- JSFFI sync imports, the result is just (IO a) or a,+ -- and res_trans is id; for async cases, the result is+ -- always (IO JSVal), and res_trans will wrap it in a+ -- thunk that has the original return type. This way, we+ -- can reuse most of the RHS generation logic for both+ -- sync/async imports.+ (res_trans $ res_wrapper call_app)+ (zip args_unevaled args_evaled)+ pure rhs -importCStub :: Safety -> FastString -> [Type] -> Type -> String -> CStub-importCStub safety cfun_name arg_tys res_ty js_src = CStub c_doc [] []+importCStub :: Synchronicity -> FastString -> [Type] -> Type -> String -> CStub+importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] [] where import_name = fromJust $ stripPrefix "ghczuwasmzujsffi" (unpackFS cfun_name) import_asm =@@ -465,18 +473,18 @@ <> parens ( vcat [ text (show l)- | l <-- [ ".section .custom_section.ghc_wasm_jsffi,\"\",@\n",- ".asciz \"" ++ import_name ++ "\"\n",- ".asciz \""- ++ ( case safety of- PlayRisky -> "("- _ -> "async ("- )- ++ intercalate "," ["$" ++ show i | i <- [1 .. length arg_tys]]- ++ ")\"\n",- ".asciz " ++ show js_src ++ "\n"- ]+ | l <-+ [ ".section .custom_section.ghc_wasm_jsffi,\"\",@\n",+ ".asciz \"" ++ import_name ++ "\"\n",+ ".asciz \""+ ++ ( case sync of+ Sync -> "("+ Async -> "async ("+ )+ ++ intercalate "," ["$" ++ show i | i <- [1 .. length arg_tys]]+ ++ ")\"\n",+ ".asciz " ++ show js_src ++ "\n"+ ] ] ) <> semi@@ -488,8 +496,8 @@ ( punctuate comma [ text k <> parens (doubleQuotes (text v))- | (k, v) <-- [("import_module", "ghc_wasm_jsffi"), ("import_name", import_name)]+ | (k, v) <-+ [("import_module", "ghc_wasm_jsffi"), ("import_name", import_name)] ] ) )@@ -501,7 +509,7 @@ | otherwise = text ("Hs" ++ ffiType res_ty) import_arg_list = [ text ("Hs" ++ ffiType arg_ty) <+> char 'a' <> int i- | (i, arg_ty) <- zip [1 ..] arg_tys+ | (i, arg_ty) <- zip [1 ..] arg_tys ] import_args = case import_arg_list of [] -> text "void"@@ -528,7 +536,7 @@ ( punctuate comma [ cfun_make_arg arg_ty (char 'a' <> int n)- | (arg_ty, n) <- zip arg_tys [1 ..]+ | (arg_ty, n) <- zip arg_tys [1 ..] ] ) )@@ -554,7 +562,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A JSFFI static export wraps a top-level Haskell binding as a wasm-module export that can be called in JavaScript as an async function:+module export that can be called in JavaScript as an async/sync+function: foreign export javascript "plus" (+) :: Int -> Int -> Int@@ -565,32 +574,27 @@ __attribute__((export_name("plus"))) HsJSVal plus(HsInt a1, HsInt a2) { ... } +The generated C stub function would be exported as __exports.plus and+can be called in JavaScript. By default, it's exported as an async+function, so the C stub would always return an HsJSVal which+represents the result Promise; in case of a sync export (using "plus+sync" instead of "plus"), it returns the original result type.++The C stub function body applies the function closure to arguments,+wrap it with a runIO/runNonIO top handler function, then schedules+Haskell computation to happen, then fetches the result. In case of an+async export, the top handler creates a JavaScript Promise that stands+for Haskell evaluation result, and the Promise will eventually be+resolved with the result or rejected with an exception. That Promise+is what we return in the C stub function. See+Note [Async JSFFI scheduler] for detailed explanation.+ At link time, you need to pass -optl-Wl,--export=plus,--export=... to specify your entrypoint function symbols as roots of wasm-ld link-time garbage collection. As for the auto-generated exports when desugaring the JSFFI dynamic exports, they will be transitively included as well due to the export_name attribute. -For each JSFFI static export, we create an internal worker function-which takes the same arguments as the exported Haskell binding, but-always returns (IO JSVal). Its RHS simply applies the arguments to the-original binding, then applies a runIO/runNonIO top handler function-to the result. The top handler creates a JavaScript Promise that-stands for Haskell evaluation result, schedules Haskell computation to-happen, and the Promise will eventually be resolved with the result or-rejected with an exception. That Promise is what we return in the C-stub function. See Note [Async JSFFI scheduler] for detailed-explanation.--There's nothing else to explain about the C stub function body; just-like C FFI exports, it calls rts_mk* to box the arguments, rts_apply-to apply them to the worker function, evaluates the result, then-unboxes the resulting Promise using rts_getJSVal and returns it.--Now, in JavaScript, once the wasm instance is initialized, you can-directly call these exports and await them, as if they're real-JavaScript async functions.- -} dsWasmJSExport ::@@ -598,108 +602,140 @@ Coercion -> CLabelString -> DsM (CHeader, CStub, String, [Id], [Binding])-dsWasmJSExport fn_id co ext_name = do- work_uniq <- newUnique+dsWasmJSExport fn_id co str = dsWasmJSExport' sync (Just fn_id) co ext_name+ where+ (sync, ext_name) = case words $ unpackFS str of+ [ext_name] -> (Async, ext_name)+ [ext_name, "sync"] -> (Sync, ext_name)+ _ -> panic "dsWasmJSExport: unrecognized label string"++dsWasmJSExport' ::+ Synchronicity ->+ Maybe Id ->+ Coercion ->+ String ->+ DsM (CHeader, CStub, String, [Id], [Binding])+dsWasmJSExport' sync m_fn_id co ext_name = do let ty = coercionRKind co- (tvs, fun_ty) = tcSplitForAllInvisTyVars ty+ (_, fun_ty) = tcSplitForAllInvisTyVars ty (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of Just (_, res_ty) -> (res_ty, True) Nothing -> (orig_res_ty, False)- (_, res_ty_args) = splitTyConApp res_ty res_ty_str = ffiType res_ty- args <- newSysLocalsDs arg_tys+ top_handler_mod = case sync of+ Sync -> "GHC.Internal.TopHandler"+ Async -> "GHC.Internal.Wasm.Prim.Exports"+ top_handler_name+ | is_io = "runIO"+ | otherwise = "runNonIO"+ -- In case of sync export, we use the normal C FFI tophandler+ -- functions. They would call flushStdHandles in case of uncaught+ -- exception but not in normal cases, but we want flushStdHandles to+ -- be called so that there are less run-time surprises for users,+ -- and that's what our tophandler functions already do.+ --+ -- So for each sync export, we first wrap the computation with a C+ -- FFI tophandler, and then sequence it with flushStdHandles using+ -- (<*) :: IO a -> IO b -> IO a. But it's trickier to call (<*)+ -- using RTS API given type class dictionary is involved, so we'll+ -- just use finally.+ finally_id <-+ lookupGhcInternalVarId+ "GHC.Internal.Control.Exception.Base"+ "finally"+ flushStdHandles_id <-+ lookupGhcInternalVarId+ "GHC.Internal.TopHandler"+ "flushStdHandles" promiseRes_id <-- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" $ "js_promiseResolve" ++ res_ty_str- runIO_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "runIO"- runNonIO_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "runNonIO"- let work_id =- mkExportedVanillaId- ( mkExternalName- work_uniq- (nameModule $ getName fn_id)- (mkVarOcc $ "jsffi_" ++ occNameString (getOccName fn_id))- generatedSrcSpan- )- (exprType work_rhs)- work_rhs =- mkCoreLams (tvs ++ args)- $ mkApps- (Var $ if is_io then runIO_id else runNonIO_id)- [ Type res_ty,- mkApps (Var promiseRes_id) $ map Type res_ty_args,- mkApps (Cast (Var fn_id) co)- $ map (Type . mkTyVarTy) tvs- ++ map Var args- ]- work_closure = ppr work_id <> text "_closure"- work_closure_decl = text "extern StgClosure" <+> work_closure <> semi+ lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports"+ $ "js_promiseResolve"+ ++ res_ty_str+ top_handler_id <- lookupGhcInternalVarId top_handler_mod top_handler_name+ let ppr_closure c = ppr c <> text "_closure"+ mk_extern_closure_decl c =+ text "extern StgClosure" <+> ppr_closure c <> semi+ gc_root_closures = maybeToList m_fn_id ++ case sync of+ -- In case of C FFI top handlers, they are already declared in+ -- RtsAPI.h and registered as GC roots in initBuiltinGcRoots.+ -- flushStdHandles is already registered but somehow the C+ -- stub can't access its declaration, won't hurt to declare it+ -- again here.+ Sync -> [finally_id, flushStdHandles_id]+ Async -> [top_handler_id, promiseRes_id]+ extern_closure_decls = vcat $ map mk_extern_closure_decl $ top_handler_id : gc_root_closures cstub_attr = text "__attribute__" <> parens- (parens $ text "export_name" <> parens (doubleQuotes $ ftext ext_name))+ (parens $ text "export_name" <> parens (doubleQuotes $ text ext_name)) cstub_arg_list = [ text ("Hs" ++ ffiType (scaledThing arg_ty)) <+> char 'a' <> int i- | (i, arg_ty) <- zip [1 ..] arg_tys+ | (i, arg_ty) <- zip [1 ..] arg_tys ] cstub_args = case cstub_arg_list of [] -> text "void" _ -> hsep $ punctuate comma cstub_arg_list- cstub_proto = text "HsJSVal" <+> ftext ext_name <> parens cstub_args+ cstub_proto+ | Sync <- sync,+ res_ty `eqType` unitTy =+ text "void" <+> text ext_name <> parens cstub_args+ | Sync <- sync =+ text ("Hs" ++ res_ty_str) <+> text ext_name <> parens cstub_args+ | Async <- sync =+ text "HsJSVal" <+> text ext_name <> parens cstub_args+ c_closure c = char '&' <> ppr_closure c+ c_call fn args = text fn <> parens (hsep $ punctuate comma args)+ c_rts_apply =+ Data.List.foldl1' $ \fn arg -> c_call "rts_apply" [text "cap", fn, arg]+ apply_top_handler expr = case sync of+ Sync ->+ c_rts_apply+ [ c_closure finally_id,+ c_rts_apply [c_closure top_handler_id, expr],+ c_closure flushStdHandles_id+ ]+ Async ->+ c_rts_apply [c_closure top_handler_id, c_closure promiseRes_id, expr]+ cstub_ret+ | Sync <- sync, res_ty `eqType` unitTy = empty+ | Sync <- sync = text $ "return rts_get" ++ res_ty_str ++ "(ret);"+ | Async <- sync = text "return rts_getJSVal(ret);"+ (cstub_target, real_args)+ | Just fn_id <- m_fn_id = (c_closure fn_id, zip [1 ..] arg_tys)+ | otherwise = (text "(HaskellObj)deRefStablePtr(a1)", zip [2 ..] $ tail arg_tys) cstub_body = vcat [ lbrace, text "Capability *cap = rts_lock();", text "HaskellObj ret;",- -- rts_evalLazyIO is fine, the top handler always returns- -- an evaluated result- text "rts_evalLazyIO"- <> parens- ( hsep- $ punctuate- comma- [ text "&cap",- foldl'- ( \acc (i, arg_ty) ->- text "rts_apply"- <> parens- ( hsep- $ punctuate- comma- [ text "cap",- acc,- text ("rts_mk" ++ ffiType (scaledThing arg_ty))- <> parens- (hsep $ punctuate comma [text "cap", char 'a' <> int i])- ]- )- )- (char '&' <> work_closure)- $ zip [1 ..] arg_tys,- text "&ret"- ]- )+ c_call+ "rts_inCall"+ [ text "&cap",+ apply_top_handler+ $ c_rts_apply+ $ cstub_target+ : [ c_call+ ("rts_mk" ++ ffiType (scaledThing arg_ty))+ [text "cap", char 'a' <> int i]+ | (i, arg_ty) <- real_args+ ],+ text "&ret"+ ] <> semi,- text "rts_checkSchedStatus"- <> parens (doubleQuotes (ftext ext_name) <> comma <> text "cap")+ c_call "rts_checkSchedStatus" [doubleQuotes (text ext_name), text "cap"] <> semi, text "rts_unlock(cap);",- text "return rts_getJSVal(ret);",+ cstub_ret, rbrace ] cstub = commonCDecls- $+$ work_closure_decl+ $+$ extern_closure_decls $+$ cstub_attr $+$ cstub_proto $+$ cstub_body- pure- ( CHeader commonCDecls,- CStub cstub [] [],- "",- [work_id],- [(work_id, work_rhs)]- )+ pure (CHeader commonCDecls, CStub cstub [] [], "", gc_root_closures, []) lookupGhcInternalVarId :: FastString -> String -> DsM Id lookupGhcInternalVarId m v = do
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -78,7 +78,8 @@ dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))- = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty+ = updPmNablas rhs_nablas $+ matchGuards (map unLoc guards) hs_ctx rhs rhs_ty {- ************************************************************************@@ -90,7 +91,6 @@ matchGuards :: [GuardStmt GhcTc] -- Guard -> HsMatchContextRn -- Context- -> Nablas -- The RHS's covered set for PmCheck -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard -> DsM (MatchResult CoreExpr)@@ -98,8 +98,8 @@ -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuards [] _ nablas rhs _- = do { core_rhs <- updPmNablas nablas (dsLExpr rhs)+matchGuards [] _ rhs _+ = do { core_rhs <- dsLExpr rhs ; return (cantFailMatchResult core_rhs) } -- BodyStmts must be guards@@ -109,42 +109,50 @@ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do- match_result <- matchGuards stmts ctx nablas rhs rhs_ty+ match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do- match_result <- matchGuards stmts ctx nablas rhs rhs_ty+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do+ match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do- match_result <- matchGuards stmts ctx nablas rhs rhs_ty- return (adjustMatchResultDs (dsLocalBinds binds) match_result)+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do+ ldi_nablas <- getPmNablas+ match_result <- matchGuards stmts ctx rhs rhs_ty+ -- Propagate long-distance information when desugaring let bindings, e.g.+ --+ -- f r@(K1 {})+ -- | let g = fld r+ -- = g+ --+ -- Failing to do so resulted in #25749.+ return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result -- Reason: dsLet takes the body expression as its argument -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do let upat = unLoc pat match_var <- selectMatchVar ManyTy upat -- We only allow unrestricted patterns in guards, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. - match_result <- matchGuards stmts ctx nablas rhs rhs_ty+ match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx) pat rhs_ty match_result return $ bindNonRec match_var core_rhs <$> match_result' -matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"-matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =+matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"+matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" {-
compiler/GHC/HsToCore/Quote.hs view
@@ -42,7 +42,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Binds -import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Syntax as TH import GHC.Hs
compiler/GHC/Iface/Load.hs view
@@ -44,7 +44,7 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst- , tcIfaceAnnotations, tcIfaceCompleteMatches )+ , tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceDefaults) import GHC.Driver.Config.Finder import GHC.Driver.Env@@ -508,6 +508,7 @@ ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)+ ; new_eps_defaults <- tcIfaceDefaults mod (mi_defaults iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)@@ -517,6 +518,7 @@ ; let final_iface = iface & set_mi_decls (panic "No mi_decls in PIT") & set_mi_insts (panic "No mi_insts in PIT")+ & set_mi_defaults (panic "No mi_defaults in PIT") & set_mi_fam_insts (panic "No mi_fam_insts in PIT") & set_mi_rules (panic "No mi_rules in PIT") & set_mi_anns (panic "No mi_anns in PIT")@@ -574,7 +576,9 @@ eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) (length new_eps_insts)- (length new_eps_rules) }+ (length new_eps_rules),+ eps_defaults = extendModuleEnv (eps_defaults eps) mod new_eps_defaults+ } ; -- invoke plugins with *full* interface, not final_iface, to ensure -- that plugins have access to declarations, etc.
compiler/GHC/Iface/Make.hs view
@@ -411,10 +411,10 @@ defaultsToIfaceDefaults :: DefaultEnv -> [IfaceDefault] defaultsToIfaceDefaults = map toIface . defaultList where- toIface ClassDefaults { cd_class = clsTyCon+ toIface ClassDefaults { cd_class = cls , cd_types = tys , cd_warn = warn }- = IfaceDefault { ifDefaultCls = toIfaceTyCon clsTyCon+ = IfaceDefault { ifDefaultCls = className cls , ifDefaultTys = map toIfaceType tys , ifDefaultWarn = fmap toIfaceWarningTxt warn }
compiler/GHC/Iface/Rename.hs view
@@ -107,6 +107,7 @@ insts <- mapM rnIfaceClsInst (mi_insts iface) fams <- mapM rnIfaceFamInst (mi_fam_insts iface) deps <- rnDependencies (mi_deps iface)+ defaults <- mapM rnIfaceDefault (mi_defaults iface) -- TODO: -- mi_rules return $ iface@@ -117,6 +118,7 @@ & set_mi_exports exports & set_mi_decls decls & set_mi_deps deps+ & set_mi_defaults defaults -- | Rename just the exports of a 'ModIface'. Useful when we're doing -- shaping prior to signature merging.@@ -403,6 +405,14 @@ return cls_inst { ifInstCls = n , ifInstTys = tys , ifDFun = dfun+ }++rnIfaceDefault :: Rename IfaceDefault+rnIfaceDefault cls_inst = do+ n <- rnIfaceGlobal (ifDefaultCls cls_inst)+ tys <- mapM rnIfaceType (ifDefaultTys cls_inst)+ return cls_inst { ifDefaultCls = n+ , ifDefaultTys = tys } rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon)
compiler/GHC/Iface/Tidy.hs view
@@ -72,7 +72,6 @@ import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err -import GHC.Types.DefaultEnv ( emptyDefaultEnv ) import GHC.Types.ForeignStubs import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -178,7 +177,8 @@ tcg_insts = insts, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches,- tcg_mod = this_mod+ tcg_mod = this_mod,+ tcg_default_exports = default_exports } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process.@@ -186,7 +186,7 @@ (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ return (ModDetails { md_types = type_env'- , md_defaults = emptyDefaultEnv+ , md_defaults = default_exports , md_insts = insts' , md_fam_insts = fam_insts , md_rules = []
compiler/GHC/IfaceToCore.hs view
@@ -20,9 +20,10 @@ tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, typecheckWholeCoreBindings,+ tcIfaceDefaults, typecheckIfacesForMerging, typecheckIfaceForInstantiate,- tcIfaceDecl, tcIfaceDecls, tcIfaceDefaults,+ tcIfaceDecl, tcIfaceDecls, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceExpr, -- Desired by HERMIT (#7683)@@ -115,7 +116,7 @@ import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.Name.Env-import GHC.Types.DefaultEnv ( ClassDefaults(..), defaultEnv )+import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info@@ -132,9 +133,6 @@ import GHC.Unit.Module.WholeCoreBindings import Data.IORef import Data.Foldable-import Data.Function ( on )-import Data.List.NonEmpty ( NonEmpty )-import qualified Data.List.NonEmpty as NE import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) import GHC.Iface.Errors.Types import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))@@ -228,7 +226,7 @@ ; let type_env = mkNameEnv names_w_things -- Now do those rules, instances and annotations- ; defaults <- mapM (tcIfaceDefault iface_mod) (mi_defaults iface)+ ; defaults <- tcIfaceDefaults iface_mod (mi_defaults iface) ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface)@@ -247,7 +245,7 @@ -- an example where this would cause non-termination. text "Type envt:" <+> ppr (map fst names_w_things)]) ; return $ ModDetails { md_types = type_env- , md_defaults = defaultEnv defaults+ , md_defaults = defaults , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules@@ -455,7 +453,7 @@ -- But note that we use this type_env to typecheck references to DFun -- in 'IfaceInst' setImplicitEnvM type_env $ do- defaults <- mapM (tcIfaceDefault $ mi_semantic_module iface) (mi_defaults iface)+ defaults <- tcIfaceDefaults (mi_semantic_module iface) (mi_defaults iface) insts <- mapM tcIfaceInst (mi_insts iface) fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) rules <- tcIfaceRules ignore_prags (mi_rules iface)@@ -463,7 +461,7 @@ exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env- , md_defaults = defaultEnv defaults+ , md_defaults = defaults , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules@@ -497,7 +495,7 @@ return (mkNameEnv decls) -- See Note [rnIfaceNeverExported] setImplicitEnvM type_env $ do- defaults <- mapM (tcIfaceDefault iface_mod) (mi_defaults iface)+ defaults <- tcIfaceDefaults iface_mod (mi_defaults iface) insts <- mapM tcIfaceInst (mi_insts iface) fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) rules <- tcIfaceRules ignore_prags (mi_rules iface)@@ -505,7 +503,7 @@ exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env- , md_defaults = defaultEnv defaults+ , md_defaults = defaults , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules@@ -1240,23 +1238,70 @@ tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc) tcRoughTyCon Nothing = RM_WildCard -tcIfaceDefaults :: Module -> [(Module, IfaceDefault)] -> IfG [NonEmpty ClassDefaults]-tcIfaceDefaults this_mod defaults- = initIfaceLcl this_mod (text "Import defaults") NotBoot- $ NE.groupBy ((==) `on` cd_class)- <$> mapM (uncurry tcIfaceDefault) defaults+{- Note [Tricky rehydrating IfaceDefaults loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a potential circular dependency when rehydrating IfaceDefaults into+a DefaultEnv (a map from class names to defaults): +1. To construct a DefaultEnv, we need the Class objects corresponding to+ the class names in the IfaceDefault++2. If a class is defined in the current module, rehydrating it requires+ looking into the ModDetails we're currently building++3. But that ModDetails needs the DefaultEnv we're trying to create!++This creates a circular dependency:+ - DefaultEnv needs Class objects+ - Class objects (for current module) need ModDetails+ - ModDetails needs DefaultEnv++Our solution is to break this loop by using just the class name from+IfaceDefault, rather than trying to fully resolve the Class. Since+DefaultEnv is keyed by Name anyway, we don't need the full Class object+for the map construction - we only need it for the map values.++In tcIfaceDefault we create ClassDefaults records containing the actual+Class objects, but we do this *after* creating the DefaultEnv keyed by Name.++This approach allows us to tie the knot properly without causing a loop.+-}++-- | 'tcIfaceDefaults' rehydrates a list of default declarations+-- lazily, and returns a DefaultEnv.+tcIfaceDefaults :: Module -> [IfaceDefault] -> IfL DefaultEnv+tcIfaceDefaults this_mod defaults = do+ defaults <- mapM do_one defaults+ return $ mkDefaultEnv defaults+ where+ do_one idf = do+ -- Invariant: (className class_default) == name+ -- see Note [Tricky rehydrating IfaceDefaults loop]+ let name = ifDefaultCls idf++ -- Now look up the Class and the default types.+ -- We must use forkM here, as these may be knot-tied (see #25858).+ -- See Note [Rehydrating Modules] in GHC.Driver.Make+ -- as well as Note [Knot-tying typecheckIface] in GHC.IfaceToCore.+ class_default <- forkM (text "tcIfaceDefault" <+> ppr name) $ tcIfaceDefault this_mod idf+ return (name, class_default)+ tcIfaceDefault :: Module -> IfaceDefault -> IfL ClassDefaults-tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = clsCon+tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = cls_name , ifDefaultTys = tys , ifDefaultWarn = iface_warn }- = do { clsCon' <- tcIfaceTyCon clsCon+ = do { cls <- fmap tyThingConClass (tcIfaceImplicit cls_name) ; tys' <- traverse tcIfaceType tys ; let warn = fmap fromIfaceWarningTxt iface_warn- ; return ClassDefaults { cd_class = clsCon'+ ; return ClassDefaults { cd_class = cls , cd_types = tys' , cd_module = Just this_mod , cd_warn = warn } }+ where+ tyThingConClass :: TyThing -> Class+ tyThingConClass th = case tyConClass_maybe $ tyThingTyCon th of+ Just cls -> cls+ Nothing -> pprPanic "tcIfaceDefault, expected class" (ppr th) tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
compiler/GHC/IfaceToCore.hs-boot view
@@ -4,22 +4,21 @@ import GHC.Iface.Syntax ( IfaceDecl, IfaceDefault, IfaceClsInst, IfaceFamInst, IfaceRule , IfaceAnnotation, IfaceCompleteMatch ) import GHC.Types.TyThing ( TyThing )-import GHC.Tc.Types ( IfG, IfL )+import GHC.Tc.Types ( IfL ) import GHC.Core.InstEnv ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core ( CoreRule ) import GHC.Types.CompleteMatch import GHC.Types.Annotations ( Annotation )-import GHC.Types.DefaultEnv ( ClassDefaults )+import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Name import GHC.Unit.Types ( Module ) import GHC.Fingerprint.Type -import Data.List.NonEmpty ( NonEmpty ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]-tcIfaceDefaults :: Module -> [(Module, IfaceDefault)] -> IfG [NonEmpty ClassDefaults]+tcIfaceDefaults :: Module -> [IfaceDefault] -> IfL DefaultEnv tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
compiler/GHC/Linker/Dynamic.hs view
@@ -150,10 +150,6 @@ -- (and should) do without this for all libraries except -- the RTS; all we need to do is to pass the correct -- HSfoo_dyn.dylib files to the link command.- -- This feature requires Mac OS X 10.3 or later; there is- -- a similar feature, -flat_namespace -undefined suppress,- -- which works on earlier versions, but it has other- -- disadvantages. -- -single_module -- Build the dynamic library as a single "module", i.e. no -- dynamic binding nonsense when referring to symbols from
compiler/GHC/Linker/Static.hs view
@@ -250,6 +250,13 @@ ++ pkg_lib_path_opts ++ extraLinkObj ++ noteLinkObjs+ -- See Note [RTS/ghc-internal interface]+ -- (-u<sym> must come before -lghc-internal...!)+ ++ (if ghcInternalUnitId `elem` map unitId pkgs+ then [concat [ "-Wl,-u,"+ , ['_' | platformLeadingUnderscore platform]+ , "init_ghc_hs_iface" ]]+ else []) ++ pkg_link_opts ++ pkg_framework_opts ++ (if platformOS platform == OSDarwin
compiler/GHC/Llvm/Ppr.hs view
@@ -669,9 +669,7 @@ {-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ppTypeLit' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> doc-ppTypeLit' attrs opts l = case l of- LMVectorLit {} -> ppLit opts l- _ -> ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l+ppTypeLit' attrs opts l = ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l {-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc #-} {-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
compiler/GHC/Llvm/Types.hs view
@@ -239,7 +239,7 @@ pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t)-pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!"+pVarLift (LMLitVar _ ) = error $ "Can't lift a literal type!" -- | Remove the pointer indirection of the supplied type. Only 'LMPointer' -- constructors can be lowered.
compiler/GHC/Plugins.hs view
@@ -156,7 +156,7 @@ import GHC.Types.Error ( Messages ) import GHC.Hs ( HsParsedModule ) -import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Syntax as TH {- This instance is defined outside GHC.Core.Opt.Monad so that GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -}
compiler/GHC/Rename/Bind.hs view
@@ -1331,14 +1331,38 @@ -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin }) -- see Note [Empty MatchGroups]- = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt))+ = do { when (null ms) $ checkEmptyCase ctxt ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }++-- Check the validity of a MatchGroup with an empty list of alternatives.+--+-- 1. Normal `case x of {}` passes this check as long as EmptyCase is enabled.+-- Ditto lambda-case `\case {}`.+--+-- 2. Multi-case with no alternatives `\cases {}` is never valid.+--+-- 3. Other MatchGroup contexts (FunRhs, LamAlt LamSingle, etc) are not+-- considered here because there is no syntax to construct them with+-- no alternatives.+--+-- Test case: rename/should_fail/RnEmptyCaseFail+--+-- Validation continues in the type checker, namely in tcMatches.+-- See Note [Pattern types for EmptyCase] in GHC.Tc.Gen.Match+checkEmptyCase :: HsMatchContextRn -> RnM ()+checkEmptyCase ctxt+ | disallowed_ctxt =+ addErr (TcRnEmptyCase ctxt EmptyCaseDisallowedCtxt)+ | otherwise =+ unlessXOptM LangExt.EmptyCase $+ addErr (TcRnEmptyCase ctxt EmptyCaseWithoutFlag) where- mustn't_be_empty = case ctxt of- LamAlt LamCases -> return True- ArrowMatchCtxt (ArrowLamAlt LamCases) -> return True- _ -> not <$> xoptM LangExt.EmptyCase+ disallowed_ctxt =+ case ctxt of+ LamAlt LamCases -> True+ ArrowMatchCtxt (ArrowLamAlt LamCases) -> True+ _ -> False rnMatch :: AnnoBody body => HsMatchContextRn
compiler/GHC/Rename/Names.hs view
@@ -51,7 +51,7 @@ import GHC.Hs import GHC.Iface.Load ( loadSrcInterface )-import GHC.Iface.Syntax ( IfaceDefault, fromIfaceWarnings )+import GHC.Iface.Syntax ( fromIfaceWarnings ) import GHC.Builtin.Names import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Core.Type@@ -94,6 +94,7 @@ import GHC.Data.Maybe import GHC.Data.List.SetOps ( removeDups ) +import Control.Arrow ( second ) import Control.Monad import Data.Foldable ( for_ ) import Data.IntMap ( IntMap )@@ -101,6 +102,8 @@ import Data.Map ( Map ) import qualified Data.Map as Map import Data.Ord ( comparing )+import Data.Semigroup ( Any(..) )+import qualified Data.Semigroup as S import Data.List ( partition, find, sortBy ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE@@ -109,6 +112,7 @@ import System.FilePath ((</>)) import System.IO + {- ************************************************************************ * *@@ -201,7 +205,7 @@ -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary rnImports :: [(LImportDecl GhcPs, SDoc)]- -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage)+ -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do tcg_env <- getGblEnv -- NB: want an identity module here, because it's OK for a signature@@ -212,10 +216,10 @@ stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary stuff2 <- mapAndReportM (rnImportDecl this_mod) source -- Safe Haskell: See Note [Tracking Trust Transitively]- let (decls, imp_user_spec, rdr_env, imp_avails, defaults, hpc_usage) = combine (stuff1 ++ stuff2)+ let (decls, imp_user_spec, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) -- Update imp_boot_mods if imp_direct_mods mentions any of them let merged_import_avail = clobberSourceImports imp_avails- return (decls, imp_user_spec, rdr_env, merged_import_avail, defaults, hpc_usage)+ return (decls, imp_user_spec, rdr_env, merged_import_avail, hpc_usage) where clobberSourceImports imp_avails =@@ -228,23 +232,21 @@ combJ (GWIB _ IsBoot) x = Just x combJ r _ = Just r -- See Note [Combining ImportAvails]- combine :: [(LImportDecl GhcRn, ImportUserSpec, GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage)]- -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage)+ combine :: [(LImportDecl GhcRn, ImportUserSpec, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]+ -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, AnyHpcUsage) combine ss =- let (decls, imp_user_spec, rdr_env, imp_avails, defaults, hpc_usage, finsts) = foldr+ let (decls, imp_user_spec, rdr_env, imp_avails, hpc_usage, finsts) = foldr plus- ([], [], emptyGlobalRdrEnv, emptyImportAvails, [], False, emptyModuleSet)+ ([], [], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) ss- in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },- defaults, hpc_usage)+ in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, hpc_usage) - plus (decl, us, gbl_env1, imp_avails1, defaults1, hpc_usage1)- (decls, uss, gbl_env2, imp_avails2, defaults2, hpc_usage2, finsts_set)+ plus (decl, us, gbl_env1, imp_avails1, hpc_usage1)+ (decls, uss, gbl_env2, imp_avails2, hpc_usage2, finsts_set) = ( decl:decls, us:uss, gbl_env1 `plusGlobalRdrEnv` gbl_env2, imp_avails1' `plusImportAvails` imp_avails2,- defaults1 ++ defaults2, hpc_usage1 || hpc_usage2, extendModuleSetList finsts_set new_finsts ) where@@ -309,7 +311,7 @@ -- 4. A boolean 'AnyHpcUsage' which is true if the imported module -- used HPC. rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc)- -> RnM (LImportDecl GhcRn, ImportUserSpec , GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage)+ -> RnM (LImportDecl GhcRn, ImportUserSpec , GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name , ideclPkgQual = raw_pkg_qual@@ -437,8 +439,7 @@ , ideclImportList = new_imp_details } - return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env,- imports, (,) (mi_module iface) <$> mi_defaults iface, mi_hpc iface)+ return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env, imports, mi_hpc iface) -- | Rename raw package imports@@ -1844,21 +1845,21 @@ -- srcSpanEnd: see Note [The ImportMap] `orElse` [] - used_names = mkNameSet (map greName used_gres)+ used_gre_env = mkGlobalRdrEnv used_gres used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) unused_imps -- Not trivial; see eg #7454 = case imps of Just (Exactly, L _ imp_ies) ->- foldr (add_unused . unLoc) emptyNameSet imp_ies+ let unused = foldr (add_unused . unLoc) (UnusedNames emptyNameSet emptyFsEnv) imp_ies+ in collectUnusedNames unused _other -> emptyNameSet -- No explicit import list => no unused-name list - add_unused :: IE GhcRn -> NameSet -> NameSet- add_unused (IEVar _ n _) acc = add_unused_name (lieWrappedName n) acc- add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) acc+ add_unused :: IE GhcRn -> UnusedNames -> UnusedNames+ add_unused (IEVar _ n _) acc = add_unused_name (lieWrappedName n) True acc+ add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) False acc add_unused (IEThingAll _ n _) acc = add_unused_all (lieWrappedName n) acc- add_unused (IEThingWith _ p wc ns _) acc =- add_wc_all (add_unused_with pn xs acc)+ add_unused (IEThingWith _ p wc ns _) acc = add_wc_all (add_unused_with pn xs acc) where pn = lieWrappedName p xs = map lieWrappedName ns add_wc_all = case wc of@@ -1866,23 +1867,117 @@ IEWildcard _ -> add_unused_all pn add_unused _ acc = acc - add_unused_name n acc- | n `elemNameSet` used_names = acc- | otherwise = acc `extendNameSet` n- add_unused_all n acc- | n `elemNameSet` used_names = acc- | n `elemNameSet` used_parents = acc- | otherwise = acc `extendNameSet` n+ add_unused_name :: Name -> Bool -> UnusedNames -> UnusedNames+ add_unused_name n is_ie_var acc@(UnusedNames acc_ns acc_fs)+ | is_ie_var+ , isFieldName n+ -- See Note [Reporting unused imported duplicate record fields]+ = let+ fs = getOccFS n+ (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False)+ acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used)+ in UnusedNames acc_ns acc_fs'+ | used+ = acc+ | otherwise+ = UnusedNames (acc_ns `extendNameSet` n) acc_fs+ where+ used = isJust $ lookupGRE_Name used_gre_env n++ add_unused_all :: Name -> UnusedNames -> UnusedNames+ add_unused_all n (UnusedNames acc_ns acc_fs)+ | Just {} <- lookupGRE_Name used_gre_env n = UnusedNames acc_ns acc_fs+ | n `elemNameSet` used_parents = UnusedNames acc_ns acc_fs+ | otherwise = UnusedNames (acc_ns `extendNameSet` n) acc_fs++ add_unused_with :: Name -> [Name] -> UnusedNames -> UnusedNames add_unused_with p ns acc- | all (`elemNameSet` acc1) ns = add_unused_name p acc1- | otherwise = acc1+ | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1+ | otherwise = acc1 where- acc1 = foldr add_unused_name acc ns- -- If you use 'signum' from Num, then the user may well have- -- imported Num(signum). We don't want to complain that- -- Num is not itself mentioned. Hence the two cases in add_unused_with.+ acc1@(UnusedNames acc1_ns _acc1_fs) = foldr (\n acc' -> add_unused_name n False acc') acc ns+ -- If you use 'signum' from Num, then the user may well have+ -- imported Num(signum). We don't want to complain that+ -- Num is not itself mentioned. Hence the two cases in add_unused_with. +-- | An accumulator for unused names in an import list.+--+-- See Note [Reporting unused imported duplicate record fields].+data UnusedNames =+ UnusedNames+ { unused_names :: NameSet+ -- ^ Unused 'Name's in an import list, not including record fields+ -- that are plain 'IEVar' imports+ , rec_fld_uses :: FastStringEnv (NameSet, Any)+ -- ^ Record fields imported without a parent (i.e. an 'IEVar' import).+ --+ -- The 'Any' value records whether any of the record fields+ -- sharing the same underlying 'FastString' have been used.+ }+instance Outputable UnusedNames where+ ppr (UnusedNames nms flds) =+ text "UnusedNames" <+>+ braces (ppr nms <+> ppr (fmap (second getAny) flds))++-- | Collect all unused names from a 'UnusedNames' value.+collectUnusedNames :: UnusedNames -> NameSet+collectUnusedNames (UnusedNames { unused_names = nms, rec_fld_uses = flds })+ = nms S.<> unused_flds+ where+ unused_flds = nonDetFoldFsEnv collect_unused emptyNameSet flds+ collect_unused :: (NameSet, Any) -> NameSet -> NameSet+ collect_unused (nms, Any at_least_one_name_is_used) acc+ | at_least_one_name_is_used = acc+ | otherwise = unionNameSet nms acc++{- Note [Reporting unused imported duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#24035):++ {-# LANGUAGE DuplicateRecordFields #-}+ module M1 (R1(..), R2(..)) where+ data R1 = MkR1 { fld :: Int }+ data R2 = MkR2 { fld :: Int }++ {-# LANGUAGE DuplicateRecordFields #-}+ module M2 where+ import M1 (R1(MkR1), R2, fld)+ f :: R1 -> Int+ f (MkR1 { fld = x }) = x+ g :: R2 -> Int+ g _ = 3++In the import of 'M1' in 'M2', the 'fld' import resolves to two separate GREs,+namely R1(fld) and R2(fld). From the perspective of the renamer, and in particular+the 'findImportUsage' function, it's as if the user had imported the two names+separately (even though no source syntax allows that).++This means that we need to be careful when reporting unused imports: the R2(fld)+import is indeed unused, but because R1(fld) is used, we should not report+fld as unused altogether.++To achieve this, we keep track of record field imports without a parent (i.e.+using the IEVar constructor) separately from other import items, using the+UnusedNames datatype.+Once we have accumulated usages, we emit warnings for unused record fields+without parents one whole group (of record fields sharing the same textual name)+at a time, and only if *all* of the record fields in the group are unused;+see 'collectUnusedNames'.++Note that this only applies to record fields imported without a parent. If we+had:++ import M1 (R1(MkR1, fld), R2(fld))+ f :: R1 -> Int+ f (MkR1 { fld = x }) = x+ g :: R2 -> Int+ g _ = 3++then of course we should report the second 'fld' as unused.+-}++ {- Note [The ImportMap] ~~~~~~~~~~~~~~~~~~~~~~~ The ImportMap is a short-lived intermediate data structure records, for@@ -1947,12 +2042,15 @@ | null unused = return () - -- Only one import is unused, with `SrcSpan` covering only the unused item instead of- -- the whole import statement+ -- Some imports are unused: make the `SrcSpan` cover only the unused+ -- items instead of the whole import statement | Just (_, L _ imports) <- ideclImportList decl- , length unused == 1- , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports- = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused))+ , let unused_locs = [ locA loc | L loc ie <- imports+ , name <- ieNames ie+ , name `elem` unused ]+ , loc1 : locs <- unused_locs+ , let span = foldr1 combineSrcSpans ( loc1 NE.:| locs )+ = addDiagnosticAt span (TcRnUnusedImport decl (UnusedImportSome sort_unused)) -- Some imports are unused | otherwise@@ -2265,3 +2363,4 @@ checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name)+
compiler/GHC/Rename/Splice.hs view
@@ -67,7 +67,7 @@ import GHC.Tc.Zonk.Type import GHCi.RemoteTypes ( ForeignRef )-import qualified GHC.Internal.TH.Syntax as TH (Q)+import qualified GHC.Boot.TH.Syntax as TH (Q) import qualified GHC.LanguageExtensions as LangExt
compiler/GHC/Runtime/Eval.hs view
@@ -79,7 +79,7 @@ import qualified GHC.Core.Type as Type import GHC.Iface.Env ( newInteractiveBinder )-import GHC.Iface.Load ( loadSrcInterface )+import GHC.Iface.Load ( loadInterfaceForModule ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin@@ -849,7 +849,7 @@ $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) $ forM imports $ \iface_import -> do let ImpUserSpec spec details = tcIfaceImport hsc_env iface_import- iface <- loadSrcInterface (text "imported by GHCi") (moduleName $ is_mod spec) (is_isboot spec) (is_pkg_qual spec)+ iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) pure $ case details of ImpUserAll -> importsFromIface hsc_env iface spec Nothing ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns)
compiler/GHC/Settings/IO.hs view
@@ -20,13 +20,14 @@ import GHC.Settings import GHC.SysTools.BaseDir -import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class+import Data.Char import qualified Data.Map as Map import System.FilePath import System.Directory + data SettingsError = SettingsError_MissingData String | SettingsError_BadData String@@ -70,44 +71,51 @@ mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir -- see Note [tooldir: How GHC finds mingw on Windows] + -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally+ -- introduce unescaped spaces. See #24265 and #25204.+ let escaped_top_dir = escapeArg top_dir+ escaped_mtool_dir = fmap escapeArg mtool_dir++ getSetting_raw key = either pgmError pure $+ getRawSetting settingsFile mySettings key+ getSetting_topDir top key = either pgmError pure $+ getRawFilePathSetting top settingsFile mySettings key+ getSetting_toolDir top tool key =+ expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key++ getSetting :: String -> ExceptT SettingsError m String+ getSetting key = getSetting_topDir top_dir key+ getToolSetting :: String -> ExceptT SettingsError m String+ getToolSetting key = getSetting_toolDir top_dir mtool_dir key+ getFlagsSetting :: String -> ExceptT SettingsError m [String]+ getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key+ -- Make sure to unescape, as we have escaped top_dir and tool_dir.+ -- See Note [Settings file] for a little more about this file. We're -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light.- let getSetting key = either pgmError pure $- -- Escape the 'top_dir', to make sure we don't accidentally introduce an- -- unescaped space- getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key- getToolSetting :: String -> ExceptT SettingsError m String- -- Escape the 'mtool_dir', to make sure we don't accidentally introduce- -- an unescaped space- getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key- targetPlatformString <- getSetting "target platform string"+ targetPlatformString <- getSetting_raw "target platform string" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command"- cc_args_str <- getToolSetting "C compiler flags"- cxx_args_str <- getToolSetting "C++ compiler flags"+ cc_args0 <- getFlagsSetting "C compiler flags"+ cxx_args <- getFlagsSetting "C++ compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" cpp_prog <- getToolSetting "CPP command"- cpp_args_str <- getToolSetting "CPP flags"+ cpp_args <- map Option <$> getFlagsSetting "CPP flags" hs_cpp_prog <- getToolSetting "Haskell CPP command"- hs_cpp_args_str <- getToolSetting "Haskell CPP flags"+ hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags" js_cpp_prog <- getToolSetting "JavaScript CPP command"- js_cpp_args_str <- getToolSetting "JavaScript CPP flags"+ js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags" cmmCpp_prog <- getToolSetting "C-- CPP command"- cmmCpp_args_str <- getToolSetting "C-- CPP flags"+ cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags" platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else []- cpp_args = map Option (unescapeArgs cpp_args_str)- hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str)- js_cpp_args = map Option (unescapeArgs js_cpp_args_str)- cmmCpp_args = map Option (unescapeArgs cmmCpp_args_str)- cc_args = unescapeArgs cc_args_str ++ unreg_cc_args- cxx_args = unescapeArgs cxx_args_str+ cc_args = cc_args0 ++ unreg_cc_args -- The extra flags we need to pass gcc when we invoke it to compile .hc code. --@@ -149,19 +157,19 @@ -- Config.hs one day. - -- Other things being equal, as and ld are simply gcc- cc_link_args_str <- getToolSetting "C compiler link flags"+ -- Other things being equal, 'as' and 'ld' are simply 'gcc'+ cc_link_args <- getFlagsSetting "C compiler link flags" let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog- ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str)+ ld_args = map Option (cc_args ++ cc_link_args) ld_r_prog <- getToolSetting "Merge objects command"- ld_r_args <- getToolSetting "Merge objects flags"+ ld_r_args <- getFlagsSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing- | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args)+ | otherwise = Just (ld_r_prog, map Option ld_r_args) - llvmTarget <- getSetting "LLVM target"+ llvmTarget <- getSetting_raw "LLVM target" -- We just assume on command line lc_prog <- getSetting "LLVM llc command"
compiler/GHC/StgToByteCode.hs view
@@ -530,7 +530,7 @@ PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE return ( mkSlideB platform szb (d - s) -- clear to sequel- `consOL` ret) -- go+ `appOL` ret) -- go -- construct and return an unboxed tuple returnUnboxedTuple@@ -794,7 +794,7 @@ platform <- profilePlatform <$> getProfile assert (sz == wordSize platform) return () let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)- return (push_fn `appOL` (slide `consOL` unitOL ENTER))+ return (push_fn `appOL` (slide `appOL` unitOL ENTER)) do_pushes !d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps (these_args, rest_of_args) = splitAt n args@@ -1512,7 +1512,7 @@ (push_target `consOL` push_info `consOL` PUSH_BCO args_bco `consOL`- (mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL))+ (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL)) -- ----------------------------------------------------------------------------- -- Deal with a CCall.@@ -1781,10 +1781,14 @@ _ -> pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])+maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) -- Detect and extract relevant info for the tagToEnum kludge.-maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)+maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t)+ | [v] <- args = Just (v, extract_constr_Names t)+ | otherwise+ = pprPanic "StgToByteCode: tagToEnum#"+ $ text "Expected exactly one arg, but actual args are:" <+> ppr args where extract_constr_Names ty | rep_ty <- unwrapType ty@@ -1831,13 +1835,13 @@ :: StackDepth -> Sequel -> BCEnv- -> Id+ -> StgArg -> [Name] -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names = assert (notNull names) $- do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)+ do (push_arg, arg_bytes) <- pushAtom d p arg labels <- getLabelsBc (genericLength names) label_fail <- getLabelBc label_exit <- getLabelBc@@ -1926,11 +1930,12 @@ -- PUSH_G doesn't tag constructors. So we use PACK here -- if we are dealing with nullary constructor. case isDataConWorkId_maybe var of- Just con -> do- massert (isNullaryRepDataCon con)- return (unitOL (PACK con 0), szb)+ Just con+ -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make.+ | isNullaryRepDataCon con ->+ return (unitOL (PACK con 0), szb) - Nothing+ _ -- see Note [Generating code for top-level string literal bindings] | isUnliftedType (idType var) -> do massert (idType var `eqType` addrPrimTy)@@ -2244,8 +2249,8 @@ ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) -mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr-mkSlideB platform nb db = SLIDE n d+mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr+mkSlideB platform nb db = mkSlideW n d where !n = bytesToWords platform nb !d = bytesToWords platform db
compiler/GHC/StgToCmm/Monad.hs view
@@ -798,7 +798,17 @@ tinfo = TopInfo { info_tbls = DWrap infos , stack_info=sinfo} - proc_block = CmmProc tinfo lbl live blks+ -- we must be careful to:+ -- 1. not emit a proc label twice (#22792)+ -- 2. emit it at least once! (#25565)+ --+ -- (2) happened because the entry label was the label of a basic+ -- block that got dropped (empty basic block...), hence we never+ -- generated a label for it after we fixed (1) where we were+ -- always emitting entry label.+ proc_lbl = toProcDelimiterLbl lbl++ proc_block = CmmProc tinfo proc_lbl live blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
compiler/GHC/StgToCmm/Prim.hs view
@@ -1571,28 +1571,28 @@ CastDoubleToWord64Op -> translateBitcasts (MO_FW_Bitcast W64) CastWord64ToDoubleOp -> translateBitcasts (MO_WF_Bitcast W64) - IntQuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ IntQuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_S_QuotRem (wordWidth platform)) else Right (genericIntQuotRemOp (wordWidth platform)) - Int8QuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ Int8QuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_S_QuotRem W8) else Right (genericIntQuotRemOp W8) - Int16QuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ Int16QuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_S_QuotRem W16) else Right (genericIntQuotRemOp W16) - Int32QuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ Int32QuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_S_QuotRem W32) else Right (genericIntQuotRemOp W32) - WordQuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ WordQuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_U_QuotRem (wordWidth platform)) else Right (genericWordQuotRemOp (wordWidth platform)) @@ -1601,18 +1601,18 @@ then Left (MO_U_QuotRem2 (wordWidth platform)) else Right (genericWordQuotRem2Op platform) - Word8QuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ Word8QuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_U_QuotRem W8) else Right (genericWordQuotRemOp W8) - Word16QuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ Word16QuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_U_QuotRem W16) else Right (genericWordQuotRemOp W16) - Word32QuotRemOp -> \args -> flip opCallishHandledLater args $- if allowQuotRem && not (quotRemCanBeOptimized args)+ Word32QuotRemOp -> opCallishHandledLater $+ if allowQuotRem then Left (MO_U_QuotRem W32) else Right (genericWordQuotRemOp W32) @@ -1835,23 +1835,6 @@ pure $ map (CmmReg . CmmLocal) regs alwaysExternal = \_ -> PrimopCmmEmit_External- -- Note [QuotRem optimization]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops- -- (shift, .&.).- --- -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the- -- constant is a power of 2. #9041 tracks the implementation of the general- -- optimization.- --- -- `quotRem` can be optimized in the same way. However as it returns two values,- -- it is implemented as a "callish" primop which is harder to match and- -- to transform later on. For simplicity, the current implementation detects cases- -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem- -- primop into two CMM quot and rem primops.- quotRemCanBeOptimized = \case- [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)- _ -> False allowQuotRem = stgToCmmAllowQuotRemInstr cfg allowQuotRem2 = stgToCmmAllowQuotRem2 cfg
compiler/GHC/SysTools/Ar.hs view
@@ -168,7 +168,7 @@ putPaddedInt 6 own putPaddedInt 6 grp putPaddedInt 8 mode- putPaddedInt 10 (st_size + pad)+ putPaddedInt 10 st_size putByteString "\x60\x0a" putByteString file when (pad == 1) $
compiler/GHC/SysTools/Process.hs view
@@ -232,7 +232,9 @@ then does_not_exist else throwGhcExceptionIO (ProgramError $ show err) - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))+ does_not_exist =+ throwGhcExceptionIO $+ InstallationError (phase_name ++ ": could not execute: " ++ pgm) builderMainLoop :: Logger -> (String -> String) -> FilePath
compiler/GHC/SysTools/Tasks.hs view
@@ -306,14 +306,17 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version- LLVM (http://llvm.org/):- LLVM version 3.5.2+ <vendor> LLVM version 15.0.7 ...+ OR+ LLVM (http://llvm.org/):+ LLVM version 14.0.6 -} hSetBinaryMode pout False- _ <- hGetLine pout- vline <- hGetLine pout- let mb_ver = parseLlvmVersion vline+ line1 <- hGetLine pout+ mb_ver <- case parseLlvmVersion line1 of+ mb_ver@(Just _) -> return mb_ver+ Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line hClose pin hClose pout hClose perr
compiler/GHC/Tc/Gen/App.hs view
@@ -2040,6 +2040,10 @@ go_flexi1 kappa ty2 -- ty2 is zonked | -- See Note [QuickLook unification] (UQL1) simpleUnifyCheck UC_QuickLook kappa ty2+ , checkTopShape (metaTyVarInfo kappa) ty2+ -- NB: don't forget to do a shape check, as we might be dealing+ -- with an ordinary metavariable (and not a quick-look instantiation variable).+ -- (Forgetting this led to #25950.) = do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind -- unifyKind: see (UQL2) in Note [QuickLook unification] -- and (MIV2) in Note [Monomorphise instantiation variables]
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -319,8 +319,9 @@ -> CmdType -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty)- = tcCaseMatches tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)+ = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where+ ctxt = ArrowMatchCtxt ArrowCaseAlt tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') }
compiler/GHC/Tc/Gen/Bind.hs view
@@ -695,7 +695,6 @@ {- Note [Non-variable pattern bindings aren't linear] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- A fundamental limitation of the typechecking algorithm is that we cannot have a binding which, at the same time, - is linear in its rhs@@ -707,17 +706,35 @@ To address this we to do a few things -- When a pattern is annotated with a multiplicity annotation `let %q pat = rhs+- (NVP1) When a pattern is annotated with a multiplicity annotation `let %q pat = rhs in body` (note: multiplicity-annotated bindings are always parsed as a PatBind, see Note [Multiplicity annotations] in Language.Haskell.Syntax.Binds),- then the let is never generalised (we use the NoGen plan).-- Whenever the typechecker infers an AbsBind *and* the inner binding is a+ then the let is never generalised (we use the NoGen plan). We do this with a+ dedicated test in decideGeneralisationPlan.+- (NVP2) Whenever the typechecker infers an AbsBind *and* the inner binding is a non-variable PatBind, then the multiplicity of the binding is inferred to be- Many. This is a little infelicitous: sometimes the typechecker infers an- AbsBind where it didn't need to. This may cause some programs to be spuriously- rejected, when NoMonoLocalBinds is on.-- LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether.+ Many. We do this by calling manyIfPats in tcPolyInfer. This is a little+ infelicitous: sometimes the typechecker infers an AbsBind where it didn't need+ to. This may cause some programs to be spuriously rejected, when+ NoMonoLocalBinds is on.+- (NVP3) LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether.+- (NVP4) Wrinkle: even when other conditions (including MonoLocalBinds), GHC+ will generalise some binders, namely so-called closed binding groups. We need+ to make sure that the test for (NVP1) has priority over the test for closed+ binders.+- (NVP5) Wrinkle: Closed binding groups (NVP4) are usually fine to type with+ multiplicity Many. But there's one exception: when there's no binder at all,+ the binding group is considered closed. Even if the rhs contains arbitrary+ variables. + f :: () %1 -> Bool+ f x = let !() = x in True++ If we consider `!() = x` as a generalisable group (which does nothing anyway),+ then (NVP2) will infer the pattern as multiplicity Many, and reject the+ function. We don't want that, see also #25428. So we take care not to+ generalise in this case, by excluding the no-binder case from automatic+ generalisation in decideGeneralisationPlan. -} tcPolyInfer@@ -734,7 +751,7 @@ ; apply_mr <- checkMonomorphismRestriction mono_infos bind_list -- AbsBinds which are PatBinds can't be linear.- -- See Note [Non-variable pattern bindings aren't linear]+ -- See (NVP2) in Note [Non-variable pattern bindings aren't linear] ; binds' <- manyIfPats binds' ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos))@@ -1843,12 +1860,17 @@ -- See Note [Always generalise top-level bindings] | has_mult_anns_and_pats = False- -- See Note [Non-variable pattern bindings aren't linear]+ -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] - | IsGroupClosed _ True <- closed = True+ | IsGroupClosed _ True <- closed+ , not (null binders) = True -- The 'True' means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore- -- -XMonoLocalBinds, and generalise anyway+ -- -XMonoLocalBinds, and generalise anyway.+ -- Except if 'fv' is empty: there is no binder to generalise, so+ -- generalising does nothing. And trying to generalise hurts linear+ -- types (see #25428). So we don't force it.+ -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. | has_partial_sigs = True -- See Note [Partial type signatures and generalisation]
compiler/GHC/Tc/Gen/Default.hs view
@@ -12,7 +12,6 @@ import GHC.Hs import GHC.Core.Class-import GHC.Core.TyCon (TyCon) import GHC.Core.Type( typeKind ) import GHC.Types.Var( tyVarKind )@@ -36,6 +35,7 @@ import Control.Monad (void) import Data.Function (on) import Data.List.NonEmpty ( NonEmpty (..), groupBy )+import qualified Data.List.NonEmpty as NE {- Note [Named default declarations]@@ -162,19 +162,19 @@ _ -> mapM (declarationParts extra_clss) decls ; defaultEnv . concat <$> mapM (reportDuplicates here extra_clss) (groupBy ((==) `on` sndOf3) decls') } where- declarationParts :: [Class] -> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, TyCon, [Type])- reportDuplicates :: Module -> [Class] -> NonEmpty (LDefaultDecl GhcRn, TyCon, [Type]) -> TcM [ClassDefaults]+ declarationParts :: [Class] -> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, Class, [Type])+ reportDuplicates :: Module -> [Class] -> NonEmpty (LDefaultDecl GhcRn, Class, [Type]) -> TcM [ClassDefaults] declarationParts extra_clss decl@(L locn (DefaultDecl _ cls_tyMaybe mono_tys)) = addErrCtxt defaultDeclCtxt $ setSrcSpan (locA locn) $ do { tau_tys <- mapAndReportM tc_default_ty mono_tys ; def_clsCon <- case cls_tyMaybe of Nothing ->- do { numTyCon <- tcLookupTyCon numClassName- ; let classTyConAndArgKinds cls = (classTyCon cls, [], tyVarKind <$> classTyVars cls)- tyConsAndArgKinds = (numTyCon, [], [liftedTypeKind]) : map classTyConAndArgKinds extra_clss+ do { numTyCls <- tcLookupClass numClassName+ ; let classTyConAndArgKinds cls = (cls, [], tyVarKind <$> classTyVars cls)+ tyConsAndArgKinds = (numTyCls, [], [liftedTypeKind]) :| map classTyConAndArgKinds extra_clss ; void $ mapAndReportM (check_instance_any tyConsAndArgKinds) tau_tys- ; return numTyCon }+ ; return numTyCls } Just cls_name -> do { named_deflt <- xoptM LangExt.NamedDefaults ; checkErr named_deflt (TcRnIllegalNamedDefault decl)@@ -182,15 +182,14 @@ , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} , sig_body = noLocA $ HsTyVar noAnn NotPromoted cls_name}) ; (_cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDefault cls_ty- ; let clsTyCon = classTyCon cls ; case cls_arg_kinds- of [k] -> void $ mapAndReportM (check_instance_any [(clsTyCon, cls_tys, [k])]) tau_tys+ of [k] -> void $ mapAndReportM (check_instance_any (NE.singleton (cls, cls_tys, [k]))) tau_tys _ -> addErrTc (TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt cls_ty)- ; return clsTyCon }+ ; return cls } ; return (decl, def_clsCon, tau_tys) } reportDuplicates here extra_clss ((_, clsCon, tys) :| []) = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing}- | c <- clsCon : map classTyCon extra_clss ]+ | c <- clsCon : extra_clss ] -- Report an error on multiple default declarations for the same class in the same module. -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module reportDuplicates _ _ decls@((L locn _, cls, _) :| _)@@ -210,13 +209,13 @@ -- parameters and the expected kinds of the remaining parameters. We report -- an error unless there's only one remaining parameter to fill and the given -- type has the expected kind.-check_instance_any :: [(TyCon, [Type], [Kind])] -> Type -> TcM ()+check_instance_any :: NonEmpty (Class, [Type], [Kind]) -> Type -> TcM () check_instance_any deflt_clss ty = do { oks <- mapM (check_instance ty) deflt_clss- ; checkTc (or oks) (TcRnBadDefaultType ty (map fstOf3 deflt_clss))+ ; checkTc (or oks) (TcRnBadDefaultType ty (NE.map fstOf3 deflt_clss)) } -check_instance :: Type -> (TyCon, [Type], [Kind]) -> TcM Bool+check_instance :: Type -> (Class, [Type], [Kind]) -> TcM Bool -- Check that ty is an instance of cls -- We only care about whether it worked or not; return a boolean -- This checks that cls :: k -> Constraint@@ -225,15 +224,15 @@ -- concerned with classes like -- Num :: Type -> Constraint -- Foldable :: (Type->Type) -> Constraint-check_instance ty (clsTyCon, clsArgs, [cls_argKind])+check_instance ty (cls, clsArgs, [cls_argKind]) | cls_argKind `tcEqType` typeKind ty- = simplifyDefault [mkTyConApp clsTyCon (clsArgs ++ [ty])]+ = simplifyDefault [mkTyConApp (classTyCon cls) (clsArgs ++ [ty])] check_instance _ _ = return False defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: TyCon -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage+dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things) = TcRnMultipleDefaultDeclarations cls dup_things
compiler/GHC/Tc/Gen/Export.hs view
@@ -10,6 +10,7 @@ import GHC.Hs import GHC.Builtin.Names+import GHC.Core.Class import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env@@ -428,7 +429,7 @@ Nothing -> return (acc, Nothing) Just (acc', new_ie, Left cls) -> do defaults <- tcg_default <$> getGblEnv- let exported_default = filterDefaultEnv ((cls ==) . nameOccName . tyConName . cd_class) defaults+ let exported_default = filterDefaultEnv ((cls ==) . nameOccName . className . cd_class) defaults return (acc', Just (new_ie, exported_default, [])) Just (acc', new_ie, Right avail) -> return (acc', Just (new_ie, emptyDefaultEnv, [avail]))@@ -482,7 +483,7 @@ avail' <- case unLoc l of -- see Note [Default exports] IEDefault _ cls -> do- let defaultOccName = nameOccName . tyConName . cd_class+ let defaultOccName = nameOccName . className . cd_class occName = rdrNameOcc (unLoc cls) defaults <- tcg_default <$> getGblEnv when (isEmptyDefaultEnv $ filterDefaultEnv ((occName ==) . defaultOccName) defaults)
compiler/GHC/Tc/Gen/Expr.hs view
@@ -458,7 +458,7 @@ ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty- ; (mult_co_wrap, matches') <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty+ ; (mult_co_wrap, matches') <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') } tcExpr (HsIf x pred b1 b2) res_ty
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -78,7 +78,7 @@ import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( zipWithM )+import Control.Monad ( when, zipWithM ) import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell ) import Control.Monad.Trans.Class@@ -444,7 +444,7 @@ tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc) tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do checkCg (Left edecl) backendValidityOfCExport- checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)+ when (cconv /= JavaScriptCallConv) $ checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
compiler/GHC/Tc/Gen/Match.hs view
@@ -122,11 +122,12 @@ do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys , ppr pat_tys $$ ppr rhs_ty ])- ; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }+ ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches } ; return (wrap_fun <.> wrap_mult, r) } where- herald = ExpectedFunTyMatches (NameThing fun_name) matches+ herald = ExpectedFunTyMatches (NameThing fun_name) matches+ mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts })@@ -146,10 +147,11 @@ ; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->- tcMatches tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches+ tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches ; return (wrapper <.> mult_co_wrap, r) } where+ ctxt = LamAlt lam_variant herald = ExpectedFunTyLam lam_variant e -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify @@ -167,7 +169,8 @@ -} tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))- => TcMatchAltChecker body -- ^ Typecheck the alternative RHSS+ => HsMatchContextRn+ -> TcMatchAltChecker body -- ^ Typecheck the alternative RHSS -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives -> ExpRhoType -- ^ Type of the whole case expression@@ -175,8 +178,8 @@ -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty -tcCaseMatches tc_body (Scaled scrut_mult scrut_ty) matches res_ty- = tcMatches tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches+tcCaseMatches ctxt tc_body (Scaled scrut_mult scrut_ty) matches res_ty+ = tcMatches ctxt tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType@@ -223,23 +226,30 @@ -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body, Outputable (body GhcTc))- => TcMatchAltChecker body+ => HsMatchContextRn+ -> TcMatchAltChecker body -> [ExpPatType] -- ^ Expected pattern types. -> ExpRhoType -- ^ Expected result-type of the Match. -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc))) -tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches- , mg_ext = origin })+tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches+ , mg_ext = origin }) | null matches -- Deal with case e of {} -- Since there are no branches, no one else will fill in rhs_ty -- when in inference mode, so we must do it ourselves, -- here, using expTypeToType = do { tcEmitBindingUsage bottomUE- ; pat_tys <- mapM scaledExpTypeToType (filter_out_forall_pat_tys pat_tys)+ -- See Note [Pattern types for EmptyCase]+ ; let vis_pat_tys = filter isVisibleExpPatType pat_tys+ ; pat_ty <- case vis_pat_tys of+ [ExpFunPatTy t] -> scaledExpTypeToType t+ [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb)+ [] -> panic "tcMatches: no arguments in EmptyCase"+ _t1:(_t2:_ts) -> panic "tcMatches: multiple arguments in EmptyCase" ; rhs_ty <- expTypeToType rhs_ty ; return (idHsWrapper, MG { mg_alts = L l []- , mg_ext = MatchGroupTc pat_tys rhs_ty origin+ , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin }) } | otherwise@@ -261,6 +271,43 @@ where match_fun_pat_ty (ExpFunPatTy t) = Just t match_fun_pat_ty ExpForAllPatTy{} = Nothing++{- Note [Pattern types for EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In tcMatches, we might encounter an empty list of matches if the user wrote+`case x of {}` or `\case {}`.++* First of all, both `case x of {}` and `\case {}` match on exactly one visible+ argument, which follows from++ checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity+ checkArgCounts (MG { mg_alts = L _ [] })+ = return 1+ ...++ So we expect vis_pat_tys to be a singleton list [pat_ty] and panic otherwise.++ Multi-case `\cases {}` can't violate this assumption in `tcMatches` because it+ must have been rejected earlier in `rnMatchGroup`.++ Other MatchGroup contexts (function equations `f x = ...`, lambdas `\a b -> ...`,+ etc) are not considered here because there is no syntax to construct them with+ an empty list of alternatives.++* With lambda-case, we run the risk of trying to match on a type argument:++ f :: forall (xs :: Type) -> ()+ f = \case {}++ This is not valid and it used to trigger a panic in pmcMatches (#25004).+ We reject it by inspecting the expected pattern type:++ ; pat_ty <- case vis_pat_tys of+ [ExpFunPatTy t] -> ... -- value argument, ok+ [ExpForAllPatTy tvb] -> ... -- type argument, error!++ Test case: typecheck/should_fail/T25004+-} ------------- tcMatch :: (AnnoBody body)
compiler/GHC/Tc/Gen/Splice.hs view
@@ -140,8 +140,8 @@ import qualified GHC.Data.EnumSet as EnumSet -- THSyntax gives access to internal functions and data types-import qualified GHC.Internal.TH.Syntax as TH-import qualified GHC.Internal.TH.Ppr as TH+import qualified GHC.Boot.TH.Syntax as TH+import qualified GHC.Boot.TH.Ppr as TH #if defined(HAVE_INTERNAL_INTERPRETER) import Unsafe.Coerce ( unsafeCoerce )
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -11,7 +11,7 @@ import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult )-import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Syntax as TH tcTypedSplice :: Name -> LHsExpr GhcRn
compiler/GHC/Tc/Module.hs view
@@ -133,8 +133,7 @@ import GHC.Types.Error import GHC.Types.Name.Reader-import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (ClassDefaults, cd_class, cd_types),- emptyDefaultEnv, isEmptyDefaultEnv, unitDefaultEnv, lookupDefaultEnv )+import GHC.Types.DefaultEnv import GHC.Types.Fixity.Env import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) )@@ -174,6 +173,7 @@ import Control.Monad import Control.Monad.Trans.Writer.CPS import Data.Data ( Data )+import Data.Function (on) import Data.Functor.Classes ( liftEq ) import Data.List ( sort, sortBy ) import Data.List.NonEmpty ( NonEmpty (..) )@@ -409,7 +409,7 @@ reportClashingDefaultImports importsByClass local = mapM_ check importsByClass where check cds@(ClassDefaults{cd_class = cls} :| _) = do- let cdLocal = lookupDefaultEnv local (tyConName cls)+ let cdLocal = lookupDefaultEnv local (className cls) case cdLocal of Just ClassDefaults{cd_types = localTypes} | all ((`isTypeSubsequenceOf` localTypes) . cd_types) cds -> pure ()@@ -447,8 +447,11 @@ tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM ([NonEmpty ClassDefaults], TcGblEnv) tcRnImports hsc_env import_decls- = do { (rn_imports, imp_user_spec, rdr_env, imports, defaults, hpc_info) <- rnImports import_decls ;-+ = do { (rn_imports, imp_user_spec, rdr_env, imports, hpc_info) <- rnImports import_decls+ -- Get the default declarations for the classes imported by this module+ -- and group them by class.+ ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList))+ <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv ; let unitId = homeUnitId $ hsc_home_unit hsc_env@@ -473,8 +476,6 @@ updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports } } - -- Type check the imported default declarations- ; tc_defaults <- initIfaceTcRn (tcIfaceDefaults this_mod defaults) -- Update the gbl env ; updGblEnv ( \ gbl -> gbl {
compiler/GHC/Tc/Solver.hs view
@@ -57,7 +57,7 @@ import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Ppr-import GHC.Core.TyCon ( TyCon, TyConBinder, isTypeFamilyTyCon )+import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) import GHC.Types.Name import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList )@@ -3907,7 +3907,7 @@ | group'@((_,_,tv) :| _) <- unary_groups , let group = toList group' , defaultable_tyvar tv- , defaultable_classes (map (classTyCon . sndOf3) group) ]+ , defaultable_classes (map sndOf3 group) ] where simples = approximateWC True wanteds (unaries, non_unaries) = partitionWith find_unary (bagToList simples)@@ -3945,7 +3945,7 @@ -- Determines if any of the given type class constructors is in default_tys -- step (3) in Note [How type-class constraints are defaulted]- defaultable_classes :: [TyCon] -> Bool+ defaultable_classes :: [Class] -> Bool defaultable_classes clss = not . null . intersect clss $ map cd_class default_tys ------------------------------@@ -3973,8 +3973,8 @@ allConsistent ((_, sub) :| subs) = all (eqSubAt tv sub . snd) subs defaultses = [ defaults | defaults@ClassDefaults{cd_class = cls} <- default_ctys- , any (isDictForClass cls) wanteds ]- isDictForClass clcon ct = any ((clcon ==) . classTyCon . fst) (getClassPredTys_maybe $ ctPred ct)+ , any (isDictForClass (className cls)) wanteds ]+ isDictForClass clcon ct = any ((clcon ==) . className . fst) (getClassPredTys_maybe $ ctPred ct) eqSubAt :: TcTyVar -> Subst -> Subst -> Bool eqSubAt tvar s1 s2 = or $ liftA2 tcEqType (lookupTyVar s1 tvar) (lookupTyVar s2 tvar)
compiler/GHC/Tc/Solver/Dict.hs view
@@ -33,7 +33,7 @@ import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Multiplicity ( scaledThing )-import GHC.Core.Unify ( ruleMatchTyKiX )+import GHC.Core.Unify ( ruleMatchTyKiX , typesAreApart ) import GHC.Types.Name import GHC.Types.Name.Set@@ -105,21 +105,25 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) - ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys+ ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] -- Update /both/ inert_cans /and/ inert_solved_dicts. updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->- inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics- , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }- | otherwise+ inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics+ , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }+ | otherwise -> return () -- Add the new constraint to the inert set ; updInertCans (updDicts (addDict dict_ct)) } where- not_ip_for :: Type -> DictCt -> Bool- not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })- = not (mentionsIP str_ty cls tys)+ -- Does this class constraint or any of its superclasses mention+ -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?+ does_not_mention_ip_for :: Type -> DictCt -> Bool+ does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })+ = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys+ -- See Note [Using typesAreApart when calling mentionsIP]+ -- in GHC.Core.Predicate canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt -- Once-only processing of Dict constraints:@@ -213,7 +217,7 @@ * In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. -* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any+* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any existing [G] (?x :: ty'), regardless of ty'. * Wrinkle (SIP1): we must be careful of superclasses. Consider@@ -233,7 +237,7 @@ An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). But it could happen for `class xx => D xx where ...` and the constraint D (?x :: int). This corner (constraint-kinded variables instantiated with- implicit parameter constraints) is not well explorered.+ implicit parameter constraints) is not well explored. Example in #14218, and #23761 @@ -947,7 +951,8 @@ -- First check whether there is an in-scope Given that could -- match this constraint. In that case, do not use any instance -- whether top level, or local quantified constraints.--- See Note [Instance and Given overlap]+-- See Note [Instance and Given overlap] and see+-- (IL0) in Note [Rules for instance lookup] in GHC.Core.InstEnv | not (xopt LangExt.IncoherentInstances dflags) , not (isCTupleClass clas) -- It is always safe to unpack constraint tuples
compiler/GHC/Tc/Solver/Equality.hs view
@@ -193,12 +193,8 @@ then tycon tc1 tys1 tys2 else bale_out ty1 ty2 - go ty1 ty2- | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1- , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2- = do { res_a <- go ty1a ty2a- ; res_b <- go ty1b ty2b- ; return $ combine_rev mkAppTy res_b res_a }+ -- If you are temppted to add a case for AppTy/AppTy, be careful+ -- See Note [zonkEqTypes and the PKTI] go ty1@(LitTy lit1) (LitTy lit2) | lit1 == lit2@@ -274,6 +270,32 @@ combine_rev f (Right tys) (Right ty) = Right (f ty tys) +{- Note [zonkEqTypes and the PKTI]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because `zonkEqTypes` does /partial/ zonking, we need to be very careful+to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType+HsNote [The Purely Kinded Type Invariant (PKTI)].++In #26256 we try to solve this equality constraint:+ Int :-> Maybe Char ~# k0 Int (m0 Char)+where m0 and k0 are unification variables, and+ m0 :: Type -> Type+It happens that m0 was already unified+ m0 := (w0 :: kappa)+where kappa is another unification variable that is also already unified:+ kappa := Type->Type.+So the original type satisifed the PKTI, but a partially-zonked form+ k0 Int (w0 Char)+does not!! (This a bit reminiscent of Note [mkAppTyM].)++The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`.+After all, it's only supposed to be a quick hack to see if two types are already+equal; if we bale out we'll just get into the "proper" canonicaliser.++The only tricky thing about this approach is that it relies on /omitting/+code -- for the AppTy/AppTy case! Hence this Note+-}+ {- ********************************************************************* * * * canonicaliseEquality@@ -2234,7 +2256,7 @@ `GHC.Tc.Solver.Monad.checkTypeEq`. Note its orientation: The type family ends up on the left; see-Note [Orienting TyFamLHS/TyFamLHS]d. No special treatment for+Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for CycleBreakerTvs is necessary. This scenario is now easily soluble, by using the first Given to rewrite the Wanted, which can now be solved. @@ -2906,8 +2928,7 @@ type instance F (a, Int) = (Int, G a) where G is injective; and wanted constraints - [W] TF (alpha, beta) ~ fuv- [W] fuv ~ (Int, <some type>)+ [W] F (alpha, beta) ~ (Int, <some type>) The injectivity will give rise to constraints @@ -2923,8 +2944,8 @@ favour of alpha. If we instead had [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted-constraint. But when we grough it back in, it'd look like- [W] TF (gamma1, beta) ~ fuv+constraint. But when we substitute it back in, it'd look like+ [W] F (gamma1, beta) ~ fuv and exactly the same thing would happen again! Infinite loop. This all seems fragile, and it might seem more robust to avoid@@ -2981,8 +3002,9 @@ -- Work-item is a Wanted improveWantedTopFunEqs fam_tc args ev rhs_ty = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty- ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs_ty- , ppr eqns ])+ ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args+ , text "rhs:" <+> ppr rhs_ty+ , text "eqns:" <+> ppr eqns ]) ; unifyFunDeps ev Nominal $ \uenv -> uPairsTcM (bump_depth uenv) (reverse eqns) } -- Missing that `reverse` causes T13135 and T13135_simple to loop.@@ -3005,6 +3027,8 @@ = do { fam_envs <- getFamInstEnvs ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty+ ; traceTcS "improve_wanted_top_fun_eqs" $+ vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ] ; return (local_eqns ++ top_eqns) } | otherwise -- No injectivity@@ -3035,14 +3059,14 @@ -- The order of unsubstTvs is important; it must be -- in telescope order e.g. (k:*) (a:k) - ; subst <- instFlexiX subst unsubstTvs+ ; subst1 <- instFlexiX subst unsubstTvs -- If the current substitution bind [k -> *], and -- one of the un-substituted tyvars is (a::k), we'd better -- be sure to apply the current substitution to a's kind. -- Hence instFlexiX. #13135 was an example. - ; if apartnessCheck (substTys subst branch_lhs_tys) branch- then return (mkInjectivityEqns inj_args (map (substTy subst) branch_lhs_tys) lhs_tys)+ ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch+ then return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) -- NB: The fresh unification variables (from unsubstTvs) are on the left -- See Note [Improvement orientation] else return [] }
compiler/GHC/Tc/Solver/Monad.hs view
@@ -164,7 +164,7 @@ import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Constraint -import GHC.Builtin.Names ( unsatisfiableClassNameKey )+import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName ) import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep@@ -174,6 +174,7 @@ import GHC.Core.Reduction import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.Unify (typesAreApart) import GHC.Types.Name import GHC.Types.TyThing@@ -184,13 +185,13 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.Set( elementOfUniqSet ) -import GHC.Unit.Module ( HasModule, getModule, extractModule )+import GHC.Unit.Module ( HasModule, getModule, extractModule, moduleUnit, primUnit, ghcInternalUnit, bignumUnit) import qualified GHC.Rename.Env as TcM import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Misc (HasDebugCallStack, (<||>)) import GHC.Data.Bag as Bag import GHC.Data.Pair@@ -488,14 +489,92 @@ updSolvedDicts :: InstanceWhat -> DictCt -> TcS () -- Conditionally add a new item in the solved set of the monad -- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet-updSolvedDicts what dict_ct@(DictCt { di_ev = ev })+updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) | isWanted ev , instanceReturnsDictCon what- = do { traceTcS "updSolvedDicts:" $ ppr dict_ct+ = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName+ ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName+ ; let contains_callstack_or_exceptionCtx =+ mentionsIP+ (const True)+ -- NB: the name of the call-stack IP is irrelevant+ -- e.g (?foo :: CallStack) counts!+ (is_callstack <||> is_exceptionCtx)+ cls tys+ -- See Note [Don't add HasCallStack constraints to the solved set]+ ; unless contains_callstack_or_exceptionCtx $+ do { traceTcS "updSolvedDicts:" $ ppr dict_ct ; updInertSet $ \ ics ->- ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } }+ ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }+ } } | otherwise = return ()+ where++ -- Return a predicate that decides whether a type is CallStack+ -- or ExceptionContext, accounting for e.g. type family reduction, as+ -- per Note [Using typesAreApart when calling mentionsIP].+ --+ -- See Note [Using isCallStackTy in mentionsIP].+ is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)+ is_tyConTy is_eq tc_name+ = do { mb_tc <- wrapTcS $ do+ mod <- tcg_mod <$> TcM.getGblEnv+ if moduleUnit mod `elem` [primUnit, ghcInternalUnit, bignumUnit]+ then return Nothing+ else Just <$> TcM.tcLookupTyCon tc_name+ ; case mb_tc of+ Just tc ->+ return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))+ Nothing ->+ return is_eq+ }++{- Note [Don't add HasCallStack constraints to the solved set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not add solved Wanted dictionaries that mention HasCallStack constraints+to the solved set, or we might fail to accumulate the proper call stack, as was+reported in #25529.++Recall that HasCallStack constraints (and the related HasExceptionContext+constraints) are implicit parameter constraints, and are accumulated as per+Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.++When we solve a Wanted that contains a HasCallStack constraint, we don't want+to cache the result, because re-using that solution means re-using the call-stack+in a different context!++See also Note [Shadowing of implicit parameters], which deals with a similar+problem with Given implicit parameter constraints.++Note [Using isCallStackTy in mentionsIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To implement Note [Don't add HasCallStack constraints to the solved set],+we need to check whether a constraint contains a HasCallStack or HasExceptionContext+constraint. We do this using the 'mentionsIP' function, but as per+Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:++ mentionsIP+ (const True) -- (ignore the implicit parameter string)+ (isCallStackTy <||> isExceptionContextTy)++because this does not account for e.g. a type family that reduces to CallStack.+The predicate we want to use instead is:++ \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)++However, this is made difficult by the fact that CallStack and ExceptionContext+are not wired-in types; they are only known-key. This means we must look them+up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle+of typechecking ghc-internal and these data-types have not been typechecked yet!++In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'+logic.++Note that it would be somewhat painful to wire-in ExceptionContext: at the time+of writing (March 2025), this would require wiring in the ExceptionAnnotation+class, as well as SomeExceptionAnnotation, which is a data type with existentials.+-} getSolvedDicts :: TcS (DictMap DictCt) getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }
compiler/GHC/Tc/TyCl.hs view
@@ -4753,6 +4753,8 @@ ; traceTc "Done validity of data con" $ vcat [ ppr con , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)+ , text "Datacon src bangs:" <+> ppr (dataConSrcBangs con)+ , text "Datacon impl bangs:" <+> ppr (dataConImplBangs con) , text "Datacon rep type:" <+> ppr (dataConRepType con) , text "Datacon display type:" <+> ppr data_con_display_type , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
compiler/GHC/Tc/Utils/Env.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-} module GHC.Tc.Utils.Env( TyThing(..), TcTyThing(..), TcId,@@ -67,7 +68,7 @@ newDFunName, newFamInstTyConName, newFamInstAxiomName, mkStableIdFromString, mkStableIdFromName,- mkWrapperName,+ mkWrapperName, tcGetClsDefaults, ) where import GHC.Prelude@@ -106,7 +107,10 @@ import GHC.Unit.Module+import GHC.Unit.Module.ModDetails import GHC.Unit.Home+import GHC.Unit.Env+import GHC.Unit.Home.ModInfo import GHC.Unit.External import GHC.Utils.Outputable@@ -340,6 +344,20 @@ uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map getTyVar tys) +-- | Get the default types for classes+-- explicitly not combined to be use for `reportClashingDefaultImports`+tcGetClsDefaults :: [Module] -> TcM [DefaultEnv]+tcGetClsDefaults mods = do+ hug <- hsc_HUG <$> getTopEnv+ module_env_defaults <- eps_defaults <$> getEps+ liftIO $ mapMaybeM (lookupClsDefault hug module_env_defaults) mods++lookupClsDefault :: HomeUnitGraph -> ModuleEnv DefaultEnv -> Module -> IO (Maybe DefaultEnv)+lookupClsDefault hug module_env_defaults mod =+ case lookupHugByModule mod hug of+ Just hm -> pure $ Just $ md_defaults $ hm_details hm+ Nothing -> pure $ lookupModuleEnv module_env_defaults mod+ tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled)@@ -942,27 +960,27 @@ { extDef <- if extended_defaults then do { list_ty <- tcMetaTy listTyConName ; integer_ty <- tcMetaTy integerTyConName- ; foldableCls <- tcLookupTyCon foldableClassName- ; showCls <- tcLookupTyCon showClassName- ; eqCls <- tcLookupTyCon eqClassName+ ; foldableClass <- tcLookupClass foldableClassName+ ; showClass <- tcLookupClass showClassName+ ; eqClass <- tcLookupClass eqClassName ; pure $ defaultEnv- [ builtinDefaults foldableCls [list_ty]- , builtinDefaults showCls [unitTy, integer_ty, doubleTy]- , builtinDefaults eqCls [unitTy, integer_ty, doubleTy]+ [ builtinDefaults foldableClass [list_ty]+ , builtinDefaults showClass [unitTy, integer_ty, doubleTy]+ , builtinDefaults eqClass [unitTy, integer_ty, doubleTy] ] } -- Note [Extended defaults] else pure emptyDefaultEnv ; ovlStr <- if ovl_strings- then do { isStringCls <- tcLookupTyCon isStringClassName- ; pure $ unitDefaultEnv $ builtinDefaults isStringCls [stringTy]+ then do { isStringClass <- tcLookupClass isStringClassName+ ; pure $ unitDefaultEnv $ builtinDefaults isStringClass [stringTy] } else pure emptyDefaultEnv ; checkWiredInTyCon doubleTyCon ; numDef <- case lookupDefaultEnv defaults numClassName of- Nothing -> do { numCls <- tcLookupTyCon numClassName- ; integer_ty <- tcMetaTy integerTyConName- ; pure $ unitDefaultEnv $ builtinDefaults numCls [integer_ty, doubleTy]+ Nothing -> do { integer_ty <- tcMetaTy integerTyConName+ ; numClass <- tcLookupClass numClassName+ ; pure $ unitDefaultEnv $ builtinDefaults numClass [integer_ty, doubleTy] } -- The Num class is already user-defaulted, no need to construct the builtin default _ -> pure emptyDefaultEnv
compiler/GHC/Tc/Utils/Unify.hs view
@@ -2478,7 +2478,14 @@ do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs -- Attempt to unify kinds- ; co_k <- uType (mkKindEnv env ty1 ty2) (typeKind ty2) (tyVarKind tv1)+ -- When doing so, be careful to preserve orientation;+ -- see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality+ -- and wrinkle (W2) in Note [Fundeps with instances, and equality orientation]+ -- in GHC.Tc.Solver.Dict+ -- Failing to preserve orientation led to #25597.+ ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2+ ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2)+ ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) , ppr ty2 <+> dcolon <+> ppr (typeKind ty2)
compiler/GHC/ThToHs.hs view
@@ -58,7 +58,7 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe( catMaybes, isNothing ) import Data.Word (Word64)-import GHC.Internal.TH.Syntax as TH+import GHC.Boot.TH.Syntax as TH import Foreign.ForeignPtr import Foreign.Ptr import System.IO.Unsafe
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.12.2.20250421+version: 9.12.3.20251228 license: BSD-3-Clause license-file: LICENSE category: Development@@ -75,11 +75,17 @@ if impl(ghc >= 8.8.1) ghc-options: -fno-safe-haskell if flag(threaded-rts)- ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+ if impl(ghc < 9.12.3)+ ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+ else+ ghc-options: -fobject-code -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS cpp-options: -DTHREADED_RTS -DBOOTSTRAP_TH else- ghc-options: -fobject-code -package=ghc-boot-th+ if impl(ghc < 9.12.3)+ ghc-options: -fobject-code -package=ghc-boot-th+ else+ ghc-options: -fobject-code cpp-options: -DBOOTSTRAP_TH if !os(windows) build-depends: unix@@ -92,6 +98,7 @@ bytestring >= 0.11.4 && < 0.13, time >= 1.4 && < 1.15, filepath >= 1.5 && < 1.6,+ hpc >= 0.6 && < 0.8, os-string >= 2.0.1 && < 2.1, exceptions == 0.10.*, parsec,@@ -106,7 +113,7 @@ semaphore-compat, rts, hpc >= 0.6 && < 0.8,- ghc-lib-parser == 9.12.2.20250421+ ghc-lib-parser == 9.12.3.20251228 build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2 other-extensions: BangPatterns@@ -152,6 +159,10 @@ Paths_ghc_lib reexported-modules: GHC.BaseDir,+ GHC.Boot.TH.Lib.Map,+ GHC.Boot.TH.Ppr,+ GHC.Boot.TH.PprLib,+ GHC.Boot.TH.Syntax, GHC.Builtin.Names, GHC.Builtin.PrimOps, GHC.Builtin.PrimOps.Ids,@@ -341,6 +352,10 @@ GHC.Iface.Recomp.Binary, GHC.Iface.Syntax, GHC.Iface.Type,+ GHC.Internal.ForeignSrcLang,+ GHC.Internal.LanguageExtensions,+ GHC.Internal.Lexeme,+ GHC.Internal.TH.Syntax, GHC.JS.Ident, GHC.JS.JStg.Monad, GHC.JS.JStg.Syntax,@@ -363,6 +378,8 @@ GHC.Parser.HaddockLex, GHC.Parser.Header, GHC.Parser.Lexer,+ GHC.Parser.Lexer.Interface,+ GHC.Parser.Lexer.String, GHC.Parser.PostProcess, GHC.Parser.PostProcess.Haddock, GHC.Parser.String,@@ -566,15 +583,6 @@ Language.Haskell.Syntax.Pat, Language.Haskell.Syntax.Specificity, Language.Haskell.Syntax.Type- if impl(ghc < 9.12.1)- reexported-modules:- GHC.Internal.ForeignSrcLang,- GHC.Internal.LanguageExtensions,- GHC.Internal.Lexeme,- GHC.Internal.TH.Syntax,- GHC.Internal.TH.Ppr,- GHC.Internal.TH.PprLib,- GHC.Internal.TH.Lib.Map exposed-modules: Paths_ghc_lib GHC
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -601,3 +601,153 @@ #define OFFSET_spEntry_addr 0 #define REP_spEntry_addr b64 #define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]+#define OFFSET_HsIface_processRemoteCompletion_closure 0+#define REP_HsIface_processRemoteCompletion_closure b64+#define HsIface_processRemoteCompletion_closure(__ptr__) REP_HsIface_processRemoteCompletion_closure[__ptr__+OFFSET_HsIface_processRemoteCompletion_closure]+#define OFFSET_HsIface_runIO_closure 8+#define REP_HsIface_runIO_closure b64+#define HsIface_runIO_closure(__ptr__) REP_HsIface_runIO_closure[__ptr__+OFFSET_HsIface_runIO_closure]+#define OFFSET_HsIface_runNonIO_closure 16+#define REP_HsIface_runNonIO_closure b64+#define HsIface_runNonIO_closure(__ptr__) REP_HsIface_runNonIO_closure[__ptr__+OFFSET_HsIface_runNonIO_closure]+#define OFFSET_HsIface_Z0T_closure 24+#define REP_HsIface_Z0T_closure b64+#define HsIface_Z0T_closure(__ptr__) REP_HsIface_Z0T_closure[__ptr__+OFFSET_HsIface_Z0T_closure]+#define OFFSET_HsIface_True_closure 32+#define REP_HsIface_True_closure b64+#define HsIface_True_closure(__ptr__) REP_HsIface_True_closure[__ptr__+OFFSET_HsIface_True_closure]+#define OFFSET_HsIface_False_closure 40+#define REP_HsIface_False_closure b64+#define HsIface_False_closure(__ptr__) REP_HsIface_False_closure[__ptr__+OFFSET_HsIface_False_closure]+#define OFFSET_HsIface_unpackCString_closure 48+#define REP_HsIface_unpackCString_closure b64+#define HsIface_unpackCString_closure(__ptr__) REP_HsIface_unpackCString_closure[__ptr__+OFFSET_HsIface_unpackCString_closure]+#define OFFSET_HsIface_runFinalizzerBatch_closure 56+#define REP_HsIface_runFinalizzerBatch_closure b64+#define HsIface_runFinalizzerBatch_closure(__ptr__) REP_HsIface_runFinalizzerBatch_closure[__ptr__+OFFSET_HsIface_runFinalizzerBatch_closure]+#define OFFSET_HsIface_stackOverflow_closure 64+#define REP_HsIface_stackOverflow_closure b64+#define HsIface_stackOverflow_closure(__ptr__) REP_HsIface_stackOverflow_closure[__ptr__+OFFSET_HsIface_stackOverflow_closure]+#define OFFSET_HsIface_heapOverflow_closure 72+#define REP_HsIface_heapOverflow_closure b64+#define HsIface_heapOverflow_closure(__ptr__) REP_HsIface_heapOverflow_closure[__ptr__+OFFSET_HsIface_heapOverflow_closure]+#define OFFSET_HsIface_doubleReadException_closure 80+#define REP_HsIface_doubleReadException_closure b64+#define HsIface_doubleReadException_closure(__ptr__) REP_HsIface_doubleReadException_closure[__ptr__+OFFSET_HsIface_doubleReadException_closure]+#define OFFSET_HsIface_allocationLimitExceeded_closure 88+#define REP_HsIface_allocationLimitExceeded_closure b64+#define HsIface_allocationLimitExceeded_closure(__ptr__) REP_HsIface_allocationLimitExceeded_closure[__ptr__+OFFSET_HsIface_allocationLimitExceeded_closure]+#define OFFSET_HsIface_blockedIndefinitelyOnMVar_closure 96+#define REP_HsIface_blockedIndefinitelyOnMVar_closure b64+#define HsIface_blockedIndefinitelyOnMVar_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnMVar_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnMVar_closure]+#define OFFSET_HsIface_blockedIndefinitelyOnSTM_closure 104+#define REP_HsIface_blockedIndefinitelyOnSTM_closure b64+#define HsIface_blockedIndefinitelyOnSTM_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnSTM_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnSTM_closure]+#define OFFSET_HsIface_cannotCompactFunction_closure 112+#define REP_HsIface_cannotCompactFunction_closure b64+#define HsIface_cannotCompactFunction_closure(__ptr__) REP_HsIface_cannotCompactFunction_closure[__ptr__+OFFSET_HsIface_cannotCompactFunction_closure]+#define OFFSET_HsIface_cannotCompactPinned_closure 120+#define REP_HsIface_cannotCompactPinned_closure b64+#define HsIface_cannotCompactPinned_closure(__ptr__) REP_HsIface_cannotCompactPinned_closure[__ptr__+OFFSET_HsIface_cannotCompactPinned_closure]+#define OFFSET_HsIface_cannotCompactMutable_closure 128+#define REP_HsIface_cannotCompactMutable_closure b64+#define HsIface_cannotCompactMutable_closure(__ptr__) REP_HsIface_cannotCompactMutable_closure[__ptr__+OFFSET_HsIface_cannotCompactMutable_closure]+#define OFFSET_HsIface_nonTermination_closure 136+#define REP_HsIface_nonTermination_closure b64+#define HsIface_nonTermination_closure(__ptr__) REP_HsIface_nonTermination_closure[__ptr__+OFFSET_HsIface_nonTermination_closure]+#define OFFSET_HsIface_nestedAtomically_closure 144+#define REP_HsIface_nestedAtomically_closure b64+#define HsIface_nestedAtomically_closure(__ptr__) REP_HsIface_nestedAtomically_closure[__ptr__+OFFSET_HsIface_nestedAtomically_closure]+#define OFFSET_HsIface_noMatchingContinuationPrompt_closure 152+#define REP_HsIface_noMatchingContinuationPrompt_closure b64+#define HsIface_noMatchingContinuationPrompt_closure(__ptr__) REP_HsIface_noMatchingContinuationPrompt_closure[__ptr__+OFFSET_HsIface_noMatchingContinuationPrompt_closure]+#define OFFSET_HsIface_blockedOnBadFD_closure 160+#define REP_HsIface_blockedOnBadFD_closure b64+#define HsIface_blockedOnBadFD_closure(__ptr__) REP_HsIface_blockedOnBadFD_closure[__ptr__+OFFSET_HsIface_blockedOnBadFD_closure]+#define OFFSET_HsIface_runSparks_closure 168+#define REP_HsIface_runSparks_closure b64+#define HsIface_runSparks_closure(__ptr__) REP_HsIface_runSparks_closure[__ptr__+OFFSET_HsIface_runSparks_closure]+#define OFFSET_HsIface_ensureIOManagerIsRunning_closure 176+#define REP_HsIface_ensureIOManagerIsRunning_closure b64+#define HsIface_ensureIOManagerIsRunning_closure(__ptr__) REP_HsIface_ensureIOManagerIsRunning_closure[__ptr__+OFFSET_HsIface_ensureIOManagerIsRunning_closure]+#define OFFSET_HsIface_interruptIOManager_closure 184+#define REP_HsIface_interruptIOManager_closure b64+#define HsIface_interruptIOManager_closure(__ptr__) REP_HsIface_interruptIOManager_closure[__ptr__+OFFSET_HsIface_interruptIOManager_closure]+#define OFFSET_HsIface_ioManagerCapabilitiesChanged_closure 192+#define REP_HsIface_ioManagerCapabilitiesChanged_closure b64+#define HsIface_ioManagerCapabilitiesChanged_closure(__ptr__) REP_HsIface_ioManagerCapabilitiesChanged_closure[__ptr__+OFFSET_HsIface_ioManagerCapabilitiesChanged_closure]+#define OFFSET_HsIface_runHandlersPtr_closure 200+#define REP_HsIface_runHandlersPtr_closure b64+#define HsIface_runHandlersPtr_closure(__ptr__) REP_HsIface_runHandlersPtr_closure[__ptr__+OFFSET_HsIface_runHandlersPtr_closure]+#define OFFSET_HsIface_flushStdHandles_closure 208+#define REP_HsIface_flushStdHandles_closure b64+#define HsIface_flushStdHandles_closure(__ptr__) REP_HsIface_flushStdHandles_closure[__ptr__+OFFSET_HsIface_flushStdHandles_closure]+#define OFFSET_HsIface_runMainIO_closure 216+#define REP_HsIface_runMainIO_closure b64+#define HsIface_runMainIO_closure(__ptr__) REP_HsIface_runMainIO_closure[__ptr__+OFFSET_HsIface_runMainIO_closure]+#define OFFSET_HsIface_Czh_con_info 224+#define REP_HsIface_Czh_con_info b64+#define HsIface_Czh_con_info(__ptr__) REP_HsIface_Czh_con_info[__ptr__+OFFSET_HsIface_Czh_con_info]+#define OFFSET_HsIface_Izh_con_info 232+#define REP_HsIface_Izh_con_info b64+#define HsIface_Izh_con_info(__ptr__) REP_HsIface_Izh_con_info[__ptr__+OFFSET_HsIface_Izh_con_info]+#define OFFSET_HsIface_Fzh_con_info 240+#define REP_HsIface_Fzh_con_info b64+#define HsIface_Fzh_con_info(__ptr__) REP_HsIface_Fzh_con_info[__ptr__+OFFSET_HsIface_Fzh_con_info]+#define OFFSET_HsIface_Dzh_con_info 248+#define REP_HsIface_Dzh_con_info b64+#define HsIface_Dzh_con_info(__ptr__) REP_HsIface_Dzh_con_info[__ptr__+OFFSET_HsIface_Dzh_con_info]+#define OFFSET_HsIface_Wzh_con_info 256+#define REP_HsIface_Wzh_con_info b64+#define HsIface_Wzh_con_info(__ptr__) REP_HsIface_Wzh_con_info[__ptr__+OFFSET_HsIface_Wzh_con_info]+#define OFFSET_HsIface_Ptr_con_info 272+#define REP_HsIface_Ptr_con_info b64+#define HsIface_Ptr_con_info(__ptr__) REP_HsIface_Ptr_con_info[__ptr__+OFFSET_HsIface_Ptr_con_info]+#define OFFSET_HsIface_FunPtr_con_info 280+#define REP_HsIface_FunPtr_con_info b64+#define HsIface_FunPtr_con_info(__ptr__) REP_HsIface_FunPtr_con_info[__ptr__+OFFSET_HsIface_FunPtr_con_info]+#define OFFSET_HsIface_I8zh_con_info 288+#define REP_HsIface_I8zh_con_info b64+#define HsIface_I8zh_con_info(__ptr__) REP_HsIface_I8zh_con_info[__ptr__+OFFSET_HsIface_I8zh_con_info]+#define OFFSET_HsIface_I16zh_con_info 296+#define REP_HsIface_I16zh_con_info b64+#define HsIface_I16zh_con_info(__ptr__) REP_HsIface_I16zh_con_info[__ptr__+OFFSET_HsIface_I16zh_con_info]+#define OFFSET_HsIface_I32zh_con_info 304+#define REP_HsIface_I32zh_con_info b64+#define HsIface_I32zh_con_info(__ptr__) REP_HsIface_I32zh_con_info[__ptr__+OFFSET_HsIface_I32zh_con_info]+#define OFFSET_HsIface_I64zh_con_info 312+#define REP_HsIface_I64zh_con_info b64+#define HsIface_I64zh_con_info(__ptr__) REP_HsIface_I64zh_con_info[__ptr__+OFFSET_HsIface_I64zh_con_info]+#define OFFSET_HsIface_W8zh_con_info 320+#define REP_HsIface_W8zh_con_info b64+#define HsIface_W8zh_con_info(__ptr__) REP_HsIface_W8zh_con_info[__ptr__+OFFSET_HsIface_W8zh_con_info]+#define OFFSET_HsIface_W16zh_con_info 328+#define REP_HsIface_W16zh_con_info b64+#define HsIface_W16zh_con_info(__ptr__) REP_HsIface_W16zh_con_info[__ptr__+OFFSET_HsIface_W16zh_con_info]+#define OFFSET_HsIface_W32zh_con_info 336+#define REP_HsIface_W32zh_con_info b64+#define HsIface_W32zh_con_info(__ptr__) REP_HsIface_W32zh_con_info[__ptr__+OFFSET_HsIface_W32zh_con_info]+#define OFFSET_HsIface_W64zh_con_info 344+#define REP_HsIface_W64zh_con_info b64+#define HsIface_W64zh_con_info(__ptr__) REP_HsIface_W64zh_con_info[__ptr__+OFFSET_HsIface_W64zh_con_info]+#define OFFSET_HsIface_StablePtr_con_info 352+#define REP_HsIface_StablePtr_con_info b64+#define HsIface_StablePtr_con_info(__ptr__) REP_HsIface_StablePtr_con_info[__ptr__+OFFSET_HsIface_StablePtr_con_info]+#define OFFSET_HsIface_StackSnapshot_closure 360+#define REP_HsIface_StackSnapshot_closure b64+#define HsIface_StackSnapshot_closure(__ptr__) REP_HsIface_StackSnapshot_closure[__ptr__+OFFSET_HsIface_StackSnapshot_closure]+#define OFFSET_HsIface_divZZeroException_closure 368+#define REP_HsIface_divZZeroException_closure b64+#define HsIface_divZZeroException_closure(__ptr__) REP_HsIface_divZZeroException_closure[__ptr__+OFFSET_HsIface_divZZeroException_closure]+#define OFFSET_HsIface_underflowException_closure 376+#define REP_HsIface_underflowException_closure b64+#define HsIface_underflowException_closure(__ptr__) REP_HsIface_underflowException_closure[__ptr__+OFFSET_HsIface_underflowException_closure]+#define OFFSET_HsIface_overflowException_closure 384+#define REP_HsIface_overflowException_closure b64+#define HsIface_overflowException_closure(__ptr__) REP_HsIface_overflowException_closure[__ptr__+OFFSET_HsIface_overflowException_closure]+#define OFFSET_HsIface_unpackCStringzh_info 392+#define REP_HsIface_unpackCStringzh_info b64+#define HsIface_unpackCStringzh_info(__ptr__) REP_HsIface_unpackCStringzh_info[__ptr__+OFFSET_HsIface_unpackCStringzh_info]+#define OFFSET_HsIface_unpackCStringUtf8zh_info 400+#define REP_HsIface_unpackCStringUtf8zh_info b64+#define HsIface_unpackCStringUtf8zh_info(__ptr__) REP_HsIface_unpackCStringUtf8zh_info[__ptr__+OFFSET_HsIface_unpackCStringUtf8zh_info]