diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -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 "" diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -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. diff --git a/compiler/GHC/Cmm/Config.hs b/compiler/GHC/Cmm/Config.hs --- a/compiler/GHC/Cmm/Config.hs +++ b/compiler/GHC/Cmm/Config.hs @@ -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 diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -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 diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -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])) diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -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 } diff --git a/compiler/GHC/CmmToAsm/RV64/CodeGen.hs b/compiler/GHC/CmmToAsm/RV64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/RV64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/RV64/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/RV64/Instr.hs b/compiler/GHC/CmmToAsm/RV64/Instr.hs --- a/compiler/GHC/CmmToAsm/RV64/Instr.hs +++ b/compiler/GHC/CmmToAsm/RV64/Instr.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/RV64/Ppr.hs b/compiler/GHC/CmmToAsm/RV64/Ppr.hs --- a/compiler/GHC/CmmToAsm/RV64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/RV64/Ppr.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/Wasm/Asm.hs b/compiler/GHC/CmmToAsm/Wasm/Asm.hs --- a/compiler/GHC/CmmToAsm/Wasm/Asm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Asm.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Wasm/Types.hs b/compiler/GHC/CmmToAsm/Wasm/Types.hs --- a/compiler/GHC/CmmToAsm/Wasm/Types.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Types.hs @@ -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) diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -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 diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -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, but overflowBit is i1, so we need to cast (Cmm expects -- both to be i) (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 diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -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 diff --git a/compiler/GHC/Core/LateCC/OverloadedCalls.hs b/compiler/GHC/Core/LateCC/OverloadedCalls.hs --- a/compiler/GHC/Core/LateCC/OverloadedCalls.hs +++ b/compiler/GHC/Core/LateCC/OverloadedCalls.hs @@ -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 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 ... 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 ... + in ... jmp f x + +And sometimes this works! But sometimes the full rhs would look something like: + + join g x = .... + join f x = scc ... -> 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 diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -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] ~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -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) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -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 diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs --- a/compiler/GHC/Driver/Config/Cmm.hs +++ b/compiler/GHC/Driver/Config/Cmm.hs @@ -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 diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs --- a/compiler/GHC/Driver/Config/CmmToAsm.hs +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -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) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -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) diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -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 } diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Foreign/Wasm.hs b/compiler/GHC/HsToCore/Foreign/Wasm.hs --- a/compiler/GHC/HsToCore/Foreign/Wasm.hs +++ b/compiler/GHC/HsToCore/Foreign/Wasm.hs @@ -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 diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -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" {- diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -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 diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -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. diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -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 } diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -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) diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -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 = [] diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -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 diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -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] diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -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 diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -250,6 +250,13 @@ ++ pkg_lib_path_opts ++ extraLinkObj ++ noteLinkObjs + -- See Note [RTS/ghc-internal interface] + -- (-u 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 diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -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 diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -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. diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -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 -} diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -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 diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -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) + diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -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 diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -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) diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -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" diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -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 } } diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs --- a/compiler/GHC/SysTools/Ar.hs +++ b/compiler/GHC/SysTools/Ar.hs @@ -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) $ diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -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 diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -306,14 +306,17 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 + 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 diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -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] diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -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') } diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -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] diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -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) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -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) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -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 ) diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot --- a/compiler/GHC/Tc/Gen/Splice.hs-boot +++ b/compiler/GHC/Tc/Gen/Splice.hs-boot @@ -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 diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -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 { diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -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) diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs --- a/compiler/GHC/Tc/Solver/Dict.hs +++ b/compiler/GHC/Tc/Solver/Dict.hs @@ -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 diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs --- a/compiler/GHC/Tc/Solver/Equality.hs +++ b/compiler/GHC/Tc/Solver/Equality.hs @@ -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, ) + [W] F (alpha, beta) ~ (Int, ) 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 [] } diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -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) } diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -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)) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -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) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h --- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +++ b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -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]