diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -397,6 +397,7 @@ import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual +import GHC.Types.Unique.FM import GHC.Unit import GHC.Unit.Env @@ -676,6 +677,7 @@ setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger + lookup_cache <- liftIO $ newMVar emptyUFM -- Interpreter interp <- if @@ -705,7 +707,7 @@ } s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader)) + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) -- JavaScript interpreter | ArchJavaScript <- platformArch (targetPlatform dflags) @@ -723,7 +725,7 @@ , jsInterpFinderOpts = initFinderOpts dflags , jsInterpFinderCache = hsc_FC hsc_env } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader)) + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) -- Internal interpreter | otherwise @@ -731,7 +733,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader)) + return (Just (Interp InternalInterp loader lookup_cache)) #else return Nothing #endif 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 @@ -82,7 +82,7 @@ | PUSH16_W !ByteOff | PUSH32_W !ByteOff - -- Push a ptr (these all map to PUSH_G really) + -- Push a (heap) ptr (these all map to PUSH_G really) | PUSH_G Name | PUSH_PRIMOP PrimOp | PUSH_BCO (ProtoBCO Name) diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -25,6 +25,7 @@ import GHCi.BreakArray import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names import GHC.Unit.Types @@ -40,6 +41,8 @@ import GHC.Types.Name import GHC.Types.Name.Env +import qualified GHC.Types.Id as Id +import GHC.Types.Unique.DFM import Language.Haskell.Syntax.Module.Name @@ -54,32 +57,33 @@ linkBCO :: Interp + -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp le bco_ix breakarray +linkBCO interp pkgs_loaded le bco_ix breakarray (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. - lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0) - ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0) + lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix breakarray) (ssElts ptrs0) return (ResolvedBCO isLittleEndian arity insns bitmap (listArray (0, fromIntegral (sizeSS lits0)-1) lits) (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word -lookupLiteral interp le ptr = case ptr of +lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word +lookupLiteral interp pkgs_loaded le ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do - Ptr a# <- lookupIE interp (itbl_env le) nm + Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrAddr nm -> do - Ptr a# <- lookupAddr interp (addr_env le) nm + Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrStr _ -> -- should be eliminated during assembleBCOs @@ -93,19 +97,19 @@ Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" (unpackFS addr_of_label_string) -lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE interp ie con_nm = +lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) +lookupIE interp pkgs_loaded ie con_nm = case lookupNameEnv ie con_nm of Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" - m <- lookupSymbol interp sym_to_find1 + m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info" case m of Just addr -> return addr Nothing -> do -- perhaps a nullary constructor? let sym_to_find2 = nameToCLabel con_nm "static_info" - n <- lookupSymbol interp sym_to_find2 + n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info" case n of Just addr -> return addr Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" @@ -113,35 +117,36 @@ unpackFS sym_to_find2) -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode -lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ()) -lookupAddr interp ae addr_nm = do +lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) +lookupAddr interp pkgs_loaded ae addr_nm = do case lookupNameEnv ae addr_nm of Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) Nothing -> do -- try looking up in the object files. let sym_to_find = nameToCLabel addr_nm "bytes" -- see Note [Bytes label] in GHC.Cmm.CLabel - m <- lookupSymbol interp sym_to_find + m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes" case m of Just ptr -> return ptr Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" (unpackFS sym_to_find) -lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ()) -lookupPrimOp interp primop = do +lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) +lookupPrimOp interp pkgs_loaded primop = do let sym_to_find = primopToCLabel primop "closure" - m <- lookupSymbol interp (mkFastString sym_to_find) + m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure" case m of Just p -> return (toRemotePtr p) Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find resolvePtr :: Interp + -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> RemoteRef BreakArray -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp le bco_ix breakarray ptr = case ptr of +resolvePtr interp pkgs_loaded le bco_ix breakarray ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group @@ -153,19 +158,41 @@ -> assertPpr (isExternalName nm) (ppr nm) $ do let sym_to_find = nameToCLabel nm "closure" - m <- lookupSymbol interp sym_to_find + m <- lookupHsSymbol interp pkgs_loaded nm "closure" case m of Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) BCOPtrPrimOp op - -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op + -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix breakarray bco BCOPtrBreakArray -> return (ResolvedBCOPtrBreakArray breakarray) + +-- | Look up the address of a Haskell symbol in the currently +-- loaded units. +-- +-- See Note [Looking up symbols in the relevant objects]. +lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ())) +lookupHsSymbol interp pkgs_loaded nm sym_suffix = do + massertPpr (isExternalName nm) (ppr nm) + let sym_to_find = nameToCLabel nm sym_suffix + pkg_id = moduleUnitId $ nameModule nm + loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id + + go (dll:dlls) = do + mb_ptr <- lookupSymbolInDLL interp dll sym_to_find + case mb_ptr of + Just ptr -> pure (Just ptr) + Nothing -> go dlls + go [] = + -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types + lookupSymbol interp sym_to_find + + go loaded_dlls linkFail :: String -> String -> IO a linkFail who what 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 @@ -213,23 +213,33 @@ = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can +-- Make a RegOff if we can. We don't perform this optimization if rep is greater +-- than the host word size because we use an Int to store the offset. See +-- #24893 and #24700. This should be fixed to ensure that optimizations don't +-- depend on the compiler host platform. cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) @@ -409,6 +419,13 @@ -- Anything else is just too hard. cmmMachOpFoldM _ _ _ = Nothing + +-- | Check that a literal width is compatible with the host word size used to +-- store offsets. This should be fixed properly (using larger types to store +-- literal offsets). See #24893 +validOffsetRep :: Width -> Bool +validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) + {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs --- a/compiler/GHC/CmmToAsm/AArch64.hs +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -47,6 +47,7 @@ patchRegsOfInstr = AArch64.patchRegsOfInstr isJumpishInstr = AArch64.isJumpishInstr jumpDestsOfInstr = AArch64.jumpDestsOfInstr + canFallthroughTo = AArch64.canFallthroughTo patchJumpInstr = AArch64.patchJumpInstr mkSpillInstr = AArch64.mkSpillInstr mkLoadInstr = AArch64.mkLoadInstr 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 @@ -383,7 +383,7 @@ -- TODO OPT: we might be able give getRegister -- a hint, what kind of register we want. -getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) getFloatReg expr = do r <- getRegister expr case r of diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -176,6 +176,8 @@ interesting _ (RegReal (RealRegSingle (-1))) = False interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +-- Note [AArch64 Register assignments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 -- @@ -198,6 +200,8 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim +-- +-- TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters = map regSingle [0..18] @@ -327,6 +331,12 @@ jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = [] + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid +canFallthroughTo (J (TBlock target)) bid = bid == target +canFallthroughTo (B (TBlock target)) bid = bid == target +canFallthroughTo _ _ = False -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -317,6 +317,7 @@ | w == W64 = text "sp" | w == W32 = text "wsp" + -- See Note [AArch64 Register assignments] ppr_reg_no w i | i < 0, w == W32 = text "wzr" | i < 0, w == W64 = text "xzr" diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs --- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -17,6 +17,7 @@ import GHC.Utils.Panic import GHC.Platform +-- TODO: Should this include the zero register? allMachRegNos :: [RegNo] allMachRegNos = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed. diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -777,10 +777,9 @@ dropJumps _ [] = [] dropJumps info (BasicBlock lbl ins:todo) | Just ins <- nonEmpty ins --This can happen because of shortcutting - , [dest] <- jumpDestsOfInstr (NE.last ins) , BasicBlock nextLbl _ : _ <- todo - , not (mapMember dest info) - , nextLbl == dest + , canFallthroughTo (NE.last ins) nextLbl + , not (mapMember nextLbl info) = BasicBlock lbl (NE.init ins) : dropJumps info todo | otherwise = BasicBlock lbl ins : dropJumps info todo diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -71,10 +71,16 @@ :: instr -> Bool - -- | Give the possible destinations of this jump instruction. + -- | Give the possible *local block* destinations of this jump instruction. -- Must be defined for all jumpish instructions. jumpDestsOfInstr :: instr -> [BlockId] + + -- | Check if the instr always transfers control flow + -- to the given block. Used by code layout to eliminate + -- jumps that can be replaced by fall through. + canFallthroughTo + :: instr -> BlockId -> Bool -- | Change the destination of this jump instruction. diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -79,8 +79,15 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, + -- | Does this jump always jump to a single destination and is shortcutable? + -- + -- We use this to determine shortcutable instructions - See Note [What is shortcutting] + -- Note that if we return a destination here we *most* support the relevant shortcutting in + -- shortcutStatics for jump tables and shortcutJump for the instructions itself. canShortcut :: instr -> Maybe jumpDest, + -- | Replace references to blockIds with other destinations - used to update jump tables. shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, + -- | Change the jump destination(s) of an instruction. shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, -- | 'Module' is only for printing internal labels. See Note [Internal proc -- labels] in CLabel. @@ -105,6 +112,25 @@ -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \@ -- when possible. } + +{- Note [supporting shortcutting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the concept of shortcutting see Note [What is shortcutting]. + +In order to support shortcutting across multiple backends uniformly we +use canShortcut, shortcutStatics and shortcutJump. + +canShortcut tells us if the backend support shortcutting of a instruction +and if so what destination we should retarget instruction to instead. + +shortcutStatics exists to allow us to update jump destinations in jump tables. + +shortcutJump updates the instructions itself. + +A backend can opt out of those by always returning Nothing for canShortcut +and implementing shortcutStatics/shortcutJump as \_ x -> x + +-} {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs --- a/compiler/GHC/CmmToAsm/PPC.hs +++ b/compiler/GHC/CmmToAsm/PPC.hs @@ -46,6 +46,7 @@ patchRegsOfInstr = PPC.patchRegsOfInstr isJumpishInstr = PPC.isJumpishInstr jumpDestsOfInstr = PPC.jumpDestsOfInstr + canFallthroughTo = PPC.canFallthroughTo patchJumpInstr = PPC.patchJumpInstr mkSpillInstr = PPC.mkSpillInstr mkLoadInstr = PPC.mkLoadInstr diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -1766,7 +1766,7 @@ _ -> panic "genCall': unknown calling conv." argReps = map (cmmExprType platform) args - (argHints, _) = foreignTargetHints target + (_, argHints) = foreignTargetHints target roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -22,6 +22,7 @@ , patchJumpInstr , patchRegsOfInstr , jumpDestsOfInstr + , canFallthroughTo , takeRegRegMoveInstr , takeDeltaInstr , mkRegRegMoveInstr @@ -509,6 +510,13 @@ BL{} -> True JMP{} -> True _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo instr bid + = case instr of + BCC _ target _ -> target == bid + BCCFAR _ target _ -> target == bid + _ -> False -- | Checks whether this instruction is a jump/branch instruction. diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -179,7 +179,8 @@ ArchPPC -> 26 ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> 32 + ArchAArch64 -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use. + -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this. ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs @@ -8,11 +8,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Platform import Data.Word -import GHC.Stack -- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp -- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON -- extension in Armv8-A. @@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31] -- FR instance implementation (See Linear.FreeRegs) -allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs +allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f) | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) | r < 32 && testBit g r = FreeRegs (clearBit g r) f @@ -127,7 +127,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs +releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f) | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r) diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -133,6 +133,11 @@ Instr instr -> isJumpishInstr instr _ -> False + canFallthroughTo i bid + = case i of + Instr instr -> canFallthroughTo instr bid + _ -> False + jumpDestsOfInstr i = case i of Instr instr -> jumpDestsOfInstr instr diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs --- a/compiler/GHC/CmmToAsm/X86.hs +++ b/compiler/GHC/CmmToAsm/X86.hs @@ -51,6 +51,7 @@ patchRegsOfInstr = X86.patchRegsOfInstr isJumpishInstr = X86.isJumpishInstr jumpDestsOfInstr = X86.jumpDestsOfInstr + canFallthroughTo = X86.canFallthroughTo patchJumpInstr = X86.patchJumpInstr mkSpillInstr = X86.mkSpillInstr mkLoadInstr = X86.mkLoadInstr 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 @@ -2441,10 +2441,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall32 addr conv dest_regs args = do +genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do config <- getConfig let platform = ncgPlatform config - prom_args = map (maybePromoteCArg platform W32) args + args_hints = zip args (argHints ++ repeat NoHint) + prom_args = map (maybePromoteCArg platform W32) args_hints -- If the size is smaller than the word, we widen things (see maybePromoteCArg) arg_size_bytes :: CmmType -> Int @@ -2598,10 +2599,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall64 addr conv dest_regs args = do +genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do platform <- getPlatform -- load up the register arguments - let prom_args = map (maybePromoteCArg platform W32) args + let args_hints = zip args (argHints ++ repeat NoHint) + let prom_args = map (maybePromoteCArg platform W32) args_hints let load_args :: [CmmExpr] -> [Reg] -- int regs avail for args @@ -2839,9 +2841,11 @@ assign_code dest_regs) -maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr -maybePromoteCArg platform wto arg - | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] +maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr +maybePromoteCArg platform wto (arg, hint) + | wfrom < wto = case hint of + SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg] + _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] | otherwise = arg where wfrom = cmmExprWidth platform arg @@ -3205,7 +3209,6 @@ -> FMASign -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register genFMA3Code w signs x y z = do - -- For the FMA instruction, we want to compute x * y + z -- -- There are three possible instructions we could emit: @@ -3226,17 +3229,45 @@ -- -- Currently we follow neither of these optimisations, -- opting to always use fmadd213 for simplicity. + -- + -- We would like to compute the result directly into the requested register. + -- To do so we must first compute `x` into the destination register. This is + -- only possible if the other arguments don't use the destination register. + -- We check for this and if there is a conflict we move the result only after + -- the computation. See #24496 how this went wrong in the past. let rep = floatFormat w (y_reg, y_code) <- getNonClobberedReg y - (z_reg, z_code) <- getNonClobberedReg z + (z_op, z_code) <- getNonClobberedOperand z x_code <- getAnyReg x + x_tmp <- getNewRegNat rep let fma213 = FMA3 rep signs FMA213 - code dst - = y_code `appOL` + + code, code_direct, code_mov :: Reg -> InstrBlock + -- Ideal: Compute the result directly into dst + code_direct dst = x_code dst `snocOL` + fma213 z_op y_reg dst + -- Fallback: Compute the result into a tmp reg and then move it. + code_mov dst = x_code x_tmp `snocOL` + fma213 z_op y_reg x_tmp `snocOL` + MOV rep (OpReg x_tmp) (OpReg dst) + + code dst = + y_code `appOL` z_code `appOL` - x_code dst `snocOL` - fma213 (OpReg z_reg) y_reg dst + ( if arg_regs_conflict then code_mov dst else code_direct dst ) + + where + + arg_regs_conflict = + y_reg == dst || + case z_op of + OpReg z_reg -> z_reg == dst + OpAddr amode -> dst `elem` addrModeRegs amode + OpImm {} -> False + + -- NB: Computing the result into a desired register using Any can be tricky. + -- So for now, we keep it simple. (See #24496). return (Any rep code) ----------- 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 @@ -31,6 +31,7 @@ , mkSpillInstr , mkRegRegMoveInstr , jumpDestsOfInstr + , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr @@ -664,6 +665,17 @@ CALL{} -> True _ -> False +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid + = case insn of + JXX _ target -> bid == target + JMP_TBL _ targets _ _ -> all isTargetBid targets + _ -> False + where + isTargetBid target = case target of + Nothing -> True + Just (DestBlockId target) -> target == bid + _ -> False jumpDestsOfInstr :: Instr diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -2349,7 +2349,7 @@ -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] +setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) = diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -19,8 +19,7 @@ import GHC.Prelude import GHC.Core -import GHC.Core.Utils ( exprType, findDefault, isJoinBind - , exprIsTickedString_maybe ) +import GHC.Core.Utils import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon @@ -49,7 +48,7 @@ import GHC.Data.FastString import GHC.Platform ( Platform ) import GHC.Platform.Ways -import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) +import GHC.Builtin.PrimOps import GHC.Utils.Outputable import GHC.Utils.Monad @@ -574,6 +573,19 @@ -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- +getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg +-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg. +-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or +-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. +-- Good thing we can just call `trivial_expr_fold` here. +getStgArgFromTrivialArg e + | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8, + = StgLitArg (LitString s) -- where we used to treat strings as valid StgArgs + | otherwise + = trivial_expr_fold StgVarArg StgLitArg panic panic e + where + panic = pprPanic "getStgArgFromTrivialArg" (ppr e) + coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs [] = return ([], []) @@ -586,42 +598,29 @@ = do { (args', ts) <- coreToStgArgs args ; return (StgVarArg coercionTokenId : args', ts) } -coreToStgArgs (Tick t e : args) - = assert (not (tickishIsCode t)) $ - do { (args', ts) <- coreToStgArgs (e : args) - ; let !t' = coreToStgTick (exprType e) t - ; return (args', t':ts) } - coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, ticks) <- coreToStgArgs args - arg' <- coreToStgExpr arg - let - (aticks, arg'') = stripStgTicksTop tickishFloatable arg' - stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) - StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'') - - -- WARNING: what if we have an argument like (v `cast` co) - -- where 'co' changes the representation type? - -- (This really only happens if co is unsafe.) - -- Then all the getArgAmode stuff in CgBindery will set the - -- cg_rep of the CgIdInfo based on the type of v, rather - -- than the type of 'co'. - -- This matters particularly when the function is a primop - -- or foreign call. - -- Wanted: a better solution than this hacky warning - + -- We know that `arg` must be trivial, but it may contain Ticks. + -- Example from test case `decodeMyStack`: + -- $ @... ((src Data.Tuple.snd) @Int @[..]) + -- Note that unfortunately the Tick is not at the top. + -- So we'll traverse the expression twice: + -- * Once with `stripTicksT` (which collects *all* ticks from the expression) + -- * and another time with `getStgArgFromTrivialArg`. + -- Since the argument is trivial, the only place the Tick can occur is + -- somehow wrapping a variable (give or take type args, as above). platform <- getPlatform - let - arg_rep = typePrimRep (exprType arg) - stg_arg_rep = typePrimRep (stgArgType stg_arg) + let arg_ty = exprType arg + ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg) + arg' = getStgArgFromTrivialArg arg + arg_rep = typePrimRep arg_ty + stg_arg_rep = typePrimRep (stgArgType arg') bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) - warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $ - return (stg_arg : stg_args, ticks ++ aticks) + massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) + warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ()) + + return (arg' : stg_args, ticks' ++ ticks) coreToStgTick :: Type -- type of the ticked expression -> CoreTickish diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs --- a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -80,6 +80,7 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") { -- Don't do case-of-case transformations. -- This makes full laziness work better + -- See Note [Case-of-case and full laziness] sm_case_case = False } @@ -89,3 +90,37 @@ (True, True) -> FloatEnabled (True, False)-> FloatNestedOnly (False, _) -> FloatDisabled + + +{- Note [Case-of-case and full laziness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case-of-case can hide opportunities for let-floating (full laziness). +For example + rec { f = \y. case (expensive x) of (a,b) -> blah } +We might hope to float the (expensive x) out of the \y-loop. +But if we inline `expensive` we might get + \y. case (case x of I# x' -> body) of (a,b) -> blah +Now if we do case-of-case we get + \y. case x if I# x2 -> + case body of (a,b) -> blah + +Sadly, at this point `body` mentions `x2`, so we can't float it out of the +\y-loop. + +Solution: don't do case-of-case in the "gentle" simplification phase that +precedes the first float-out transformation. Implementation: + + * `sm_case_case` field in SimplMode + + * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case + in GHC.Core.Opt.Simplify.Iteration.rebuildCall. + +Wrinkles + +* This applies equally to the case-of-runRW# transformation: + case (runRW# (\s. body)) of (a,b) -> blah + ---> + runRW# (\s. case body of (a,b) -> blah) + Again, don't do this when `sm_case_case` is off. See #25055 for + a motivating example. +-} diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -2647,7 +2647,7 @@ case interp of -- always generate JS code for the JS interpreter (no bytecode!) - Interp (ExternalInterp (ExtJS i)) _ -> + Interp (ExternalInterp (ExtJS i)) _ _ -> jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id _ -> do diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -311,16 +311,16 @@ -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Sometimes user doesn't want GHC to pick up modules, not explicitly listed --- in a command line. For example, cabal may want to enable this warning --- when building a library, so that GHC warns user about modules, not listed --- neither in `exposed-modules`, nor in `other-modules`. +-- Sometimes we don't want GHC to process modules that weren't specified as +-- explicit targets. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns the user about modules listed +-- neither in `exposed-modules` nor in `other-modules`. -- --- Here "home module" means a module, that doesn't come from an other package. +-- Here "home module" means a module that doesn't come from another package. -- -- For example, if GHC is invoked with modules "A" and "B" as targets, -- but "A" imports some other module "C", then GHC will issue a warning --- about module "C" not being listed in a command line. +-- about module "C" not being listed in the command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages @@ -331,8 +331,6 @@ where diag_opts = initDiagOpts dflags - is_known_module mod = any (is_my_target mod) targets - -- We need to be careful to handle the case where (possibly -- path-qualified) filenames (aka 'TargetFile') rather than module -- names are being passed on the GHC command-line. @@ -341,28 +339,30 @@ -- `ghc --make -isrc-exe Main` are supposed to be equivalent. -- Note also that we can't always infer the associated module name -- directly from the filename argument. See #13727. - is_my_target mod target = - let tuid = targetUnitId target - in case targetId target of - TargetModule name - -> moduleName (ms_mod mod) == name - && tuid == ms_unitid mod - TargetFile target_file _ - | Just mod_file <- ml_hs_file (ms_location mod) - -> - augmentByWorkingDirectory dflags target_file == mod_file || + is_known_module mod = + (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod)) + || + maybe False is_file_target (ml_hs_file (ms_location mod)) - -- Don't warn on B.hs-boot if B.hs is specified (#16551) - addBootSuffix target_file == mod_file || + is_file_target file = Set.member (withoutExt file) file_targets - -- We can get a file target even if a module name was - -- originally specified in a command line because it can - -- be converted in guessTarget (by appending .hs/.lhs). - -- So let's convert it back and compare with module name - mkModuleName (fst $ splitExtension target_file) - == moduleName (ms_mod mod) - _ -> False + file_targets = Set.fromList (mapMaybe file_target targets) + file_target Target {targetId} = + case targetId of + TargetModule _ -> Nothing + TargetFile file _ -> + Just (withoutExt (augmentByWorkingDirectory dflags file)) + + mod_targets = Map.fromList (mod_target <$> targets) + + mod_target Target {targetUnitId, targetId} = + case targetId of + TargetModule name -> (name, targetUnitId) + TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId) + + withoutExt = fst . splitExtension + missing = map (moduleName . ms_mod) $ filter (not . is_known_module) $ (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) @@ -1578,8 +1578,8 @@ let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 root_map = mkRootMap rootSummariesOk checkDuplicates root_map - (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps) + (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) + let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1673,19 +1673,19 @@ -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit loopSummaries :: [ModSummary] - -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId), + -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) - -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache) + -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache) loopSummaries [] done = return done - loopSummaries (ms:next) (done, pkgs, summarised) + loopSummaries (ms:next) (done, summarised) | Just {} <- M.lookup k done - = loopSummaries next (done, pkgs, summarised) + = loopSummaries next (done, summarised) -- Didn't work out what the imports mean yet, now do that. | otherwise = do - (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised + (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'') + (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'') where k = NodeKey_Module (msKey ms) @@ -1705,18 +1705,17 @@ -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> IO ([NodeKey], Set.Set (UnitId, UnitId), - + -> IO ([NodeKey], M.Map NodeKey ModuleGraphNode, DownsweepCache) -- The result is the completed NodeMap - loopImports [] done summarised = return ([], Set.empty, done, summarised) + loopImports [] done summarised = return ([], done, summarised) loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised | Just summs <- M.lookup cache_key summarised = case summs of [Right ms] -> do let nk = NodeKey_Module (msKey ms) - (rest, pkgs, summarised', done') <- loopImports ss done summarised - return (nk: rest, pkgs, summarised', done') + (rest, summarised', done') <- loopImports ss done summarised + return (nk: rest, summarised', done') [Left _err] -> loopImports ss done summarised _errs -> do @@ -1728,69 +1727,77 @@ Nothing excl_mods case mb_s of NotThere -> loopImports ss done summarised - External uid -> do - (other_deps, pkgs, done', summarised') <- loopImports ss done summarised - return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised') + External _ -> do + (other_deps, done', summarised') <- loopImports ss done summarised + return (other_deps, done', summarised') FoundInstantiation iud -> do - (other_deps, pkgs, done', summarised') <- loopImports ss done summarised - return (NodeKey_Unit iud : other_deps, pkgs, done', summarised') + (other_deps, done', summarised') <- loopImports ss done summarised + return (NodeKey_Unit iud : other_deps, done', summarised') FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) FoundHome s -> do - (done', pkgs1, summarised') <- - loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised) - (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised' + (done', summarised') <- + loopSummaries [s] (done, Map.insert cache_key [Right s] summarised) + (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised) + return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised) where cache_key = (home_uid, mb_pkg, unLoc <$> gwib) home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib wanted_mod = L loc mod --- This function checks then important property that if both p and q are home units +-- | This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] --- Fast path, trivially closed. -checkHomeUnitsClosed ue home_id_set home_imp_ids - | Set.size home_id_set == 1 = [] - | otherwise = - let res = foldMap loop home_imp_ids - -- Now check whether everything which transitively depends on a home_unit is actually a home_unit - -- These units are the ones which we need to load as home packages but failed to do for some reason, - -- it's a bug in the tool invoking GHC. - bad_unit_ids = Set.difference res home_id_set - in if Set.null bad_unit_ids - then [] - else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] - +-- +-- See Note [Multiple Home Units], section 'Closure Property'. +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] +checkHomeUnitsClosed ue + | Set.null bad_unit_ids = [] + | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] where + home_id_set = unitEnv_keys $ ue_home_unit_graph ue + bad_unit_ids = upwards_closure Set.\\ home_id_set rootLoc = mkGeneralSrcSpan (fsLit "") - -- TODO: This could repeat quite a bit of work but I struggled to write this function. - -- Which units transitively depend on a home unit - loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit - loop (from_uid, uid) = - let us = ue_findHomeUnitEnv from_uid ue in - let um = unitInfoMap (homeUnitEnv_units us) in - case lookupUniqMap um uid of - Nothing -> pprPanic "uid not found" (ppr uid) - Just ui -> - let depends = unitDepends ui - home_depends = Set.fromList depends `Set.intersection` home_id_set - other_depends = Set.fromList depends `Set.difference` home_id_set - in - -- Case 1: The unit directly depends on a home_id - if not (null home_depends) - then - let res = foldMap (loop . (from_uid,)) other_depends - in Set.insert uid res - -- Case 2: Check the rest of the dependencies, and then see if any of them depended on - else - let res = foldMap (loop . (from_uid,)) other_depends - in - if not (Set.null res) - then Set.insert uid res - else res + + graph :: Graph (Node UnitId UnitId) + graph = graphFromEdgedVerticesUniq graphNodes + + -- downwards closure of graph + downwards_closure + = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps) + | (uid, deps) <- M.toList (allReachable graph node_key)] + + inverse_closure = transposeG downwards_closure + + upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + + all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) + all_unit_direct_deps + = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + where + go rest this this_uis = + plusUniqMap_C Set.union + (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) + rest + where + external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) + this_units = homeUnitEnv_units this_uis + this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] + + graphNodes :: [Node UnitId UnitId] + graphNodes = go Set.empty home_id_set + where + go done todo + = case Set.minView todo of + Nothing -> [] + Just (uid, todo') + | Set.member uid done -> go done todo' + | otherwise -> case lookupUniqMap all_unit_direct_deps uid of + Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) + Just depends -> + let todo'' = (depends Set.\\ done) `Set.union` todo' + in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to 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 @@ -999,7 +999,11 @@ attrs :: String attrs = intercalate "," $ mattr - ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse4.2" | isSse4_2Enabled dflags ] + ++ ["+popcnt" | isSse4_2Enabled dflags ] + -- LLVM gates POPCNT instructions behind the popcnt flag, + -- while the GHC NCG (as well as GCC, Clang) gates it + -- behind SSE4.2 instead. ++ ["+sse2" | isSse2Enabled platform ] ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ] @@ -1075,14 +1079,18 @@ The command used for object linking is set using the -pgmlm and -optlm command-line options. -Sadly, the LLD linker that we use on Windows does not support the `-r` flag -needed to support object merging (see #21068). For this reason on Windows we do -not support GHCi objects. To deal with foreign stubs we build a static archive -of all of a module's object files instead merging them. Consequently, we can -end up producing `.o` files which are in fact static archives. However, -toolchains generally don't have a problem with this as they use file headers, -not the filename, to determine the nature of inputs. +However, `ld -r` is broken in some cases: + * The LLD linker that we use on Windows does not support the `-r` + flag needed to support object merging (see #21068). For this reason + on Windows we do not support GHCi objects. + +In these cases, we bundle a module's own object file with its foreign +stub's object file, instead of merging them. Consequently, we can end +up producing `.o` files which are in fact static archives. This can +only work if `ar -L` is supported, so the archive `.o` files can be +properly added to the final static library. + Note that this has somewhat non-obvious consequences when producing initializers and finalizers. See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details. @@ -1107,7 +1115,7 @@ -- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () joinObjectFiles hsc_env o_files output_fn - | can_merge_objs && not dashLSupported = do + | can_merge_objs = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) ( 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 @@ -401,17 +401,11 @@ Int -- total size of arguments ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = ( header_bits + = + ( header_bits , CStub body [] [] , type_string, - sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM + aug_arg_size ) where platform = targetPlatform dflags @@ -450,6 +444,19 @@ | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info | otherwise = arg_info + aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + -- AK: This seems just wrong, the code here uses widthInBytes, but when + -- we pass args on the haskell stack we always extend to multiples of 8 + -- to my knowledge. Not sure if it matters though so I won't touch this + -- for now. + stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, typeCmmType platform (mkStablePtrPrimTy alphaTy)) @@ -605,8 +612,11 @@ -> [(SDoc, SDoc, Type, CmmType)] go 6 args = ret_addr_arg platform : args go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args + -- Int type fitting into int register + | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep) + = arg : go (n+1) args + | otherwise + = arg : go n args go _ [] = [] in go 0 args _ -> diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -70,7 +70,10 @@ -- Other flags which affect code generation codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters)) + -- Did we include core for all bindings? + fat_iface = gopt Opt_WriteIfSimplifiedCore dflags + + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags 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 @@ -615,8 +615,11 @@ getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc - | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make - | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + | otherwise = [] + -- The 'otherwise' includes family TyCons of course, but also (less obviously) + -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + -- * type data: we don't want any code for type-only stuff (#24620) getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -56,6 +56,7 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Iface.Load +import GHCi.Message (LoadedDLL) import GHC.ByteCode.Linker import GHC.ByteCode.Asm @@ -145,7 +146,7 @@ -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet) + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = @@ -194,8 +195,8 @@ -> SrcSpan -> [Module] -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required +-- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do --- initLoaderState (hsc_dflags hsc_env) dl let opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required @@ -485,25 +486,25 @@ DLL dll_unadorned -> do maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn logger "done" - Just mm | platformOS platform /= OSDarwin -> + Right _ -> maybePutStrLn logger "done" + Left mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do + Left mm | otherwise -> do -- As a backup, on Darwin, try to also load a .so file -- since (apparently) some things install that way - see -- ticket #8770. let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL interp libfile case err2 of - Nothing -> maybePutStrLn logger "done" - Just _ -> preloadFailed mm lib_paths lib_spec + Right _ -> maybePutStrLn logger "done" + Left _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL interp dll_path case maybe_errstr of - Nothing -> maybePutStrLn logger "done" - Just mm -> preloadFailed mm lib_paths lib_spec + Right _ -> maybePutStrLn logger "done" + Left mm -> preloadFailed mm lib_paths lib_spec return pls Framework framework -> @@ -588,7 +589,7 @@ let le = linker_env pls nobreakarray = error "no break array" bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco + resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix nobreakarray root_ul_bco [root_hvref] <- createBCOs interp [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv) @@ -651,7 +652,7 @@ , addr_env = plusNameEnv (addr_env le) bc_strs } -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs interp le2 [cbc] + new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc] nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let ce2 = extendClosureEnv (closure_env le2) nms_fhvs !pls2 = pls { linker_env = le2 { closure_env = ce2 } } @@ -832,8 +833,8 @@ changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] m <- loadDLL interp soFile case m of - Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } - Just err -> linkFail msg err + Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Left err -> linkFail msg err where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -873,7 +874,7 @@ ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) le2 = le1 { itbl_env = ie2, addr_env = ae2 } - names_and_refs <- linkSomeBCOs interp le2 cbcs + names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -888,6 +889,7 @@ -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp + -> PkgsLoaded -> LinkerEnv -> [CompiledByteCode] -> IO [(Name,HValueRef)] @@ -895,7 +897,7 @@ -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs interp le mods = foldr fun do_link mods [] +linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = case bc_breaks of @@ -908,7 +910,7 @@ let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] names = map (unlinkedBCOName . snd) flat bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO interp le bco_ix breakarray bco + resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix breakarray bco | (breakarray, bco) <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -1071,18 +1073,18 @@ -- Link dependents first ; pkgs' <- link pkgs deps -- Now link the package itself - ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg + ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) } + ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) +loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) loadPackage interp hsc_env pkg = do let dflags = hsc_dflags hsc_env @@ -1124,7 +1126,9 @@ let classifieds = hs_classifieds ++ extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's. - let known_dlls = [ dll | DLLPath dll <- classifieds ] + let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ] + known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ] + known_dlls = known_hs_dlls ++ known_extra_dlls #if defined(CAN_LOAD_DLL) dlls = [ dll | DLL dll <- classifieds ] #endif @@ -1145,10 +1149,13 @@ loadFrameworks interp platform pkg -- See Note [Crash early load_dyn and locateLib] -- Crash early if can't load any of `known_dlls` - mapM_ (load_dyn interp hsc_env True) known_dlls + mapM_ (load_dyn interp hsc_env True) known_extra_dlls + loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls +#else + let loaded_dlls = [] #endif -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link @@ -1168,7 +1175,7 @@ if succeeded ok then do maybePutStrLn logger "done." - return (hs_classifieds, extra_classifieds) + return (hs_classifieds, extra_classifieds, loaded_dlls) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) @@ -1221,19 +1228,20 @@ -- can be passed directly to loadDLL. They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, -- loadDLL is going to search the system paths to find the library. -load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO () +load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) load_dyn interp hsc_env crash_early dll = do r <- loadDLL interp dll case r of - Nothing -> return () - Just err -> + Right loaded_dll -> pure (Just loaded_dll) + Left err -> if crash_early then cmdLineErrorIO err - else + else do when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) $ logMsg logger (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) noSrcSpan $ withPprStyle defaultUserStyle (note err) + pure Nothing where diag_opts = initDiagOpts (hsc_dflags hsc_env) logger = hsc_logger hsc_env diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -172,6 +172,6 @@ findLoadDLL (p:ps) errs = do { dll <- loadDLL interp (p fwk_file) ; case dll of - Nothing -> return Nothing - Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) + Right _ -> return Nothing + Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) } diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1970,6 +1970,8 @@ is never used (invariant (I1)), so it barely makes sense to talk about the worker. A `type data` constructor only shows up in types, where it appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. + See #24620 for an example of what happens if you accidentally include + a wrapper. See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where this check is implemented. 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 @@ -626,8 +626,10 @@ -- saved/restored, but not the linker state. See #1743, test break026. mkNewId :: OccName -> Type -> Id -> IO Id mkNewId occ ty old_id - = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) - ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } + = do { name <- newInteractiveBinder hsc_env (mkVarOccFS (occNameFS occ)) (getSrcSpan old_id) + -- NB: use variable namespace. + -- Don't use record field namespaces, lest we cause #25109. + ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) } newTyVars :: UniqSupply -> [TcTyVar] -> Subst -- Similarly, clone the type variables mentioned in the types diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -37,6 +37,7 @@ -- * The object-code linker , initObjLinker , lookupSymbol + , lookupSymbolInDLL , lookupClosure , loadDLL , loadArchive @@ -158,22 +159,22 @@ - implementation of Template Haskell (GHCi.TH) - a few other things needed to run interpreted code -- top-level iserv directory, containing the codefor the external - server. This is a fairly simple wrapper, most of the functionality +- top-level iserv directory, containing the code for the external + server. This is a fairly simple wrapper, most of the functionality is provided by modules in libraries/ghci. - This module which provides the interface to the server used by the rest of GHC. -GHC works with and without -fexternal-interpreter. With the flag, all -interpreted code is run by the iserv binary. Without the flag, +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, interpreted code is run in the same process as GHC. Things that do not work with -fexternal-interpreter ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ dynCompileExpr cannot work, because we have no way to run code of an -unknown type in the remote process. This API fails with an error +unknown type in the remote process. This API fails with an error message if it is used with -fexternal-interpreter. Other Notes on Remote GHCi @@ -462,7 +463,7 @@ -- making cross-process LookupSymbol calls, so I added a GHC-side -- cache which sped things up quite a lot. We have to be careful -- to purge this cache when unloading code though. - cache <- readMVar (instLookupSymbolCache inst) + cache <- readMVar (interpLookupSymbolCache interp) case lookupUFM cache str of Just p -> return (Just p) Nothing -> do @@ -473,35 +474,72 @@ Just r -> do let p = fromRemotePtr r cache' = addToUFM cache str p - modifyMVar_ (instLookupSymbolCache inst) (const (pure cache')) + modifyMVar_ (interpLookupSymbolCache interp) (const (pure cache')) return (Just p) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ())) +lookupSymbolInDLL interp dll str = withSymbolCache interp str $ + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str)) +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbolInDLL dll (unpackFS str)) + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + lookupClosure :: Interp -> String -> IO (Maybe HValueRef) lookupClosure interp str = interpCmd interp (LookupClosure str) +-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' +-- which maps symbols to the address where they are loaded. +-- When there's a cache hit we simply return the cached address, when there is +-- a miss we run the action which determines the symbol's address and populate +-- the cache with the answer. +withSymbolCache :: Interp + -> FastString + -- ^ The symbol we are looking up in the cache + -> IO (Maybe (Ptr ())) + -- ^ An action which determines the address of the symbol we + -- are looking up in the cache, which is run if there is a + -- cache miss. The result will be cached. + -> IO (Maybe (Ptr ())) +withSymbolCache interp str determine_addr = do + + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + -- + -- The analysis in #23415 further showed this cache should also benefit the + -- internal interpreter's loading times, and needn't be used by the external + -- interpreter only. + cache <- readMVar (interpLookupSymbolCache interp) + case lookupUFM cache str of + Just p -> return (Just p) + Nothing -> do + + maddr <- determine_addr + case maddr of + Nothing -> return Nothing + Just p -> do + let upd_cache cache' = addToUFM cache' str p + modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache) + return (Just p) + purgeLookupSymbolCache :: Interp -> IO () -purgeLookupSymbolCache interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> pure () -#endif - ExternalInterp ext -> withExtInterpMaybe ext $ \case - Nothing -> pure () -- interpreter stopped, nothing to do - Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM)) +purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM)) -- | loadDLL loads a dynamic library using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either -- an absolute pathname to the file, or a relative filename -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL -- searches the standard locations for the appropriate library. --- --- Returns: --- --- Nothing => success --- Just err_msg => failure -loadDLL :: Interp -> String -> IO (Maybe String) +loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) loadDLL interp str = interpCmd interp (LoadDLL str) loadArchive :: Interp -> String -> IO () @@ -560,11 +598,9 @@ } pending_frees <- newMVar [] - lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = process , instPendingFrees = pending_frees - , instLookupSymbolCache = lookup_cache , instExtra = () } pure inst diff --git a/compiler/GHC/Runtime/Interpreter/JS.hs b/compiler/GHC/Runtime/Interpreter/JS.hs --- a/compiler/GHC/Runtime/Interpreter/JS.hs +++ b/compiler/GHC/Runtime/Interpreter/JS.hs @@ -41,7 +41,6 @@ import GHC.Utils.Error (logInfo) import GHC.Utils.Outputable (text) import GHC.Data.FastString -import GHC.Types.Unique.FM import Control.Concurrent import Control.Monad @@ -178,11 +177,9 @@ } pending_frees <- newMVar [] - lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = proc , instPendingFrees = pending_frees - , instLookupSymbolCache = lookup_cache , instExtra = extra } diff --git a/compiler/GHC/Runtime/Utils.hs b/compiler/GHC/Runtime/Utils.hs --- a/compiler/GHC/Runtime/Utils.hs +++ b/compiler/GHC/Runtime/Utils.hs @@ -29,7 +29,7 @@ c__close :: CInt -> IO CInt foreign import ccall unsafe "io.h _get_osfhandle" - _get_osfhandle :: CInt -> IO CInt + _get_osfhandle :: CInt -> IO CIntPtr runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) 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 @@ -16,9 +16,11 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic +import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map @@ -72,9 +74,13 @@ -- 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 $ - getRawFilePathSetting top_dir settingsFile mySettings key + -- 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 - getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key + -- 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" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command" @@ -89,9 +95,9 @@ let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] - cpp_args = map Option (words cpp_args_str) - cc_args = words cc_args_str ++ unreg_cc_args - cxx_args = words cxx_args_str + cpp_args = map Option (unescapeArgs cpp_args_str) + cc_args = unescapeArgs cc_args_str ++ unreg_cc_args + cxx_args = unescapeArgs cxx_args_str -- The extra flags we need to pass gcc when we invoke it to compile .hc code. -- @@ -138,12 +144,12 @@ let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog - ld_args = map Option (cc_args ++ words cc_link_args_str) + ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str) ld_r_prog <- getToolSetting "Merge objects command" ld_r_args <- getToolSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option $ words ld_r_args) + | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) llvmTarget <- getSetting "LLVM target" @@ -265,3 +271,19 @@ , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit } + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -55,7 +55,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. -lookupIdSubst :: HasCallStack => Id -> Subst -> Id +lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id lookupIdSubst id (Subst in_scope env) | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id' @@ -65,7 +65,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to -- to substitute wasn't in scope. -noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id +noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id noWarnLookupIdSubst id (Subst in_scope env) | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id' 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 @@ -2074,8 +2074,8 @@ -> CmmType -- ^ index type -> AlignmentSpec alignmentFromTypes ty idx_ty - | typeWidth ty < typeWidth idx_ty = NaturallyAligned - | otherwise = Unaligned + | typeWidth ty <= typeWidth idx_ty = NaturallyAligned + | otherwise = Unaligned doIndexOffAddrOp :: Maybe MachOp -> CmmType diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -809,7 +809,7 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do platform <- getPlatform - bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes + bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes bumpTickyTagSkip :: CLabel -> FCode () bumpTickyTagSkip lbl = do diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs --- a/compiler/GHC/StgToJS/Apply.hs +++ b/compiler/GHC/StgToJS/Apply.hs @@ -44,7 +44,6 @@ import GHC.StgToJS.Stack import GHC.StgToJS.Ids -import GHC.Types.Literal import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre @@ -58,7 +57,6 @@ import GHC.Core.DataCon import GHC.Core.Type hiding (typeSize) -import GHC.Utils.Encoding import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Panic @@ -97,22 +95,6 @@ -> [StgArg] -> G (JStat, ExprResult) genApp ctx i args - - -- Case: unpackCStringAppend# "some string"# str - -- - -- Generates h$appendToHsStringA(str, "some string"), which has a faster - -- decoding loop. - | [StgLitArg (LitString bs), x] <- args - , [top] <- concatMap typex_expr (ctxTarget ctx) - , getUnique i == unpackCStringAppendIdKey - , d <- utf8DecodeByteString bs - = do - prof <- csProf <$> getSettings - let profArg = if prof then [jCafCCS] else [] - a <- genArg x - return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) - , ExprInline Nothing - ) -- let-no-escape | Just n <- ctxLneBindingStackSize ctx i diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs --- a/compiler/GHC/StgToJS/Expr.hs +++ b/compiler/GHC/StgToJS/Expr.hs @@ -57,11 +57,13 @@ import GHC.Types.Id import GHC.Types.Unique.FM import GHC.Types.RepType +import GHC.Types.Literal import GHC.Stg.Syntax import GHC.Stg.Utils import GHC.Builtin.PrimOps +import GHC.Builtin.Names import GHC.Core import GHC.Core.TyCon @@ -70,6 +72,7 @@ import GHC.Core.Type hiding (typeSize) import GHC.Utils.Misc +import GHC.Utils.Encoding import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) @@ -556,7 +559,37 @@ -> LiveVars -> G (JStat, ExprResult) genCase ctx bnd e at alts l - | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do + -- For: unpackCStringAppend# "some string"# str + -- Generate: h$appendToHsStringA(str, "some string") + -- + -- The latter has a faster decoding loop. + -- + -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we + -- need to match the following instead: + -- + -- case "some string"# of b { + -- DEFAULT -> unpackCStringAppend# b str + -- } + -- + -- Wrinkle: it doesn't kick in when literals are floated out to the top level. + -- + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , getUnique i == unpackCStringAppendIdKey + , [StgVarArg b',x] <- args + , bnd == b' + , d <- utf8DecodeByteString bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) + , ExprInline Nothing + ) + + | snd $ isInlineExpr (ctxEvaluatedIds ctx) e = do bndi <- identsForId bnd let ctx' = ctxSetTop bnd $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi)) diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs --- a/compiler/GHC/StgToJS/Literal.hs +++ b/compiler/GHC/StgToJS/Literal.hs @@ -20,6 +20,7 @@ import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic +import GHC.Types.RepType import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable @@ -66,7 +67,28 @@ | otherwise -> return [ toJExpr (TxtI (mkRawSymbol True name)) , ValExpr (JInt 0) ] - LitRubbish {} -> return [ null_ ] + LitRubbish _ rr_ty -> + -- Generate appropriate rubbish literals, otherwise it might trip up the + -- code generator when a primop is applied to a rubbish literal (see #24664) + let reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genLit") rr_ty + rub = \case + BoxedRep _ -> [ null_ ] + AddrRep -> [ null_, ValExpr (JInt 0) ] + WordRep -> [ ValExpr (JInt 0) ] + Word8Rep -> [ ValExpr (JInt 0) ] + Word16Rep -> [ ValExpr (JInt 0) ] + Word32Rep -> [ ValExpr (JInt 0) ] + Word64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] + IntRep -> [ ValExpr (JInt 0) ] + Int8Rep -> [ ValExpr (JInt 0) ] + Int16Rep -> [ ValExpr (JInt 0) ] + Int32Rep -> [ ValExpr (JInt 0) ] + Int64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] + DoubleRep -> [ ValExpr (JInt 0) ] + FloatRep -> [ ValExpr (JInt 0) ] + VoidRep -> panic "GHC.StgToJS.Literal.genLit: LitRubbish(VoidRep)" + VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported" + in return (concatMap rub reps) -- | generate a literal for the static init tables genStaticLit :: Literal -> G [StaticLit] @@ -92,7 +114,25 @@ LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) , IntLit 0 ] - l -> pprPanic "genStaticLit" (ppr l) + LitRubbish _ rep -> + let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep + in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants] + BoxedRep _ -> pure [ NullLit ] + AddrRep -> pure [ NullLit, IntLit 0 ] + IntRep -> pure [ IntLit 0 ] + Int8Rep -> pure [ IntLit 0 ] + Int16Rep -> pure [ IntLit 0 ] + Int32Rep -> pure [ IntLit 0 ] + Int64Rep -> pure [ IntLit 0, IntLit 0 ] + WordRep -> pure [ IntLit 0 ] + Word8Rep -> pure [ IntLit 0 ] + Word16Rep -> pure [ IntLit 0 ] + Word32Rep -> pure [ IntLit 0 ] + Word64Rep -> pure [ IntLit 0, IntLit 0 ] + FloatRep -> pure [ DoubleLit (SaneDouble 0) ] + DoubleRep -> pure [ DoubleLit (SaneDouble 0) ] + VoidRep -> panic "GHC.StgToJS.Literal.getStaticLit: LitRubbish(VoidRep)" + VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) -- make an unsigned 32 bit number from this unsigned one, lower 32 bits toU32Expr :: Integer -> JExpr diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs --- a/compiler/GHC/SysTools/Cpp.hs +++ b/compiler/GHC/SysTools/Cpp.hs @@ -203,11 +203,17 @@ -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath getGhcVersionPathName dflags unit_env = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) - return (( "ghcversion.h") <$> collectIncludeDirs ps) + let candidates = case ghcVersionFile dflags of + -- the user has provided an explicit `ghcversion.h` file to use. + Just path -> [path] + -- otherwise, try to find it in the rts' include-dirs. + -- Note: only in the RTS include-dirs! not all preload units less we may + -- use a wrong file. See #25106 where a globally installed + -- /usr/include/ghcversion.h file was used instead of the one provided + -- by the rts. + Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of + Nothing -> [] + Just info -> ( "ghcversion.h") <$> collectIncludeDirs [info] found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -2466,7 +2466,7 @@ ] -- | Lookup `Type` in an association list. -assoc_ty_id :: HasCallStack => String -- The class involved +assoc_ty_id :: HasDebugCallStack => String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -643,7 +643,7 @@ , sps_type_or_kind = t_or_k }) -substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec +substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps = case ps of SimplePredSpec { sps_pred = pred diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -469,6 +469,8 @@ flav = ctFlavour ct ; (suppress, m_evdest) <- case ctEvidence ct of + -- For this `suppress` stuff + -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint CtGiven {} -> return (False, Nothing) CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } -> do { rewriters' <- zonkRewriterSet rewriters diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -2551,9 +2551,11 @@ ; traceTc "kcCheckDeclHeader_sig {" $ vcat [ text "sig_kind:" <+> ppr sig_kind , text "sig_tcbs:" <+> ppr sig_tcbs - , text "sig_res_kind:" <+> ppr sig_res_kind ] + , text "sig_res_kind:" <+> ppr sig_res_kind + , text "implict_nms:" <+> ppr implicit_nms + , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ] - ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind)))) + ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind)))) <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> @@ -2605,9 +2607,18 @@ -- Here p and q both map to the same kind variable k. We don't allow this -- so we must check that they are distinct. A similar thing happens -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference. + -- + -- With visible dependent quantification, one of the binders involved + -- may be explicit. Consider #24604 + -- type UF :: forall zk -> zk -> Constraint + -- class UF kk (xb :: k) + -- Here `k` and `kk` both denote the same variable; but only `k` is implicit + -- Hence we need to add skol_scoped_tvs ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs ; let implicit_prs = implicit_nms `zip` implicit_tvs - ; checkForDuplicateScopedTyVars implicit_prs + dup_chk_prs = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs + ; unless (null implicit_nms) $ -- No need if no implicit tyvars + checkForDuplicateScopedTyVars dup_chk_prs ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs -- Swizzle the Names so that the TyCon uses the user-declared implicit names @@ -2676,6 +2687,7 @@ -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope -- Argument is excess TyConBinders and tail kind -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars + , [TcTyVar] -- Skolem tyvars brought into lexical scope by this matching-up , a ) -- See Note [Matching a kind signature with a declaration] -- Invariant: Length of returned TyConBinders + length of excess TyConBinders @@ -2686,7 +2698,7 @@ go subst tcbs [] = do { let (subst', tcbs') = substTyConBindersX subst tcbs ; res <- thing_inside tcbs' (substTy subst' sig_res_kind) - ; return ([], res) } + ; return ([], [], res) } go _ [] hs_bndrs = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs) @@ -2702,17 +2714,22 @@ -- that come from the type declaration, not the kind signature subst' = extendTCvSubstWithClone subst tv tv' ; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv') - ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $ - go subst' tcbs' hs_bndrs' - ; return (Bndr tv' vis : tcbs', res) } + ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv') + ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $ + go subst' tcbs' hs_bndrs' + ; return (Bndr tv' vis : tcbs', tv':tvs, res) } + -- We do a tcExtendTyVarEnv [tv'], so we return tv' in + -- the list of lexically-scoped skolem type variables | skippable (binderFlag tcb) = -- Invisible TyConBinder, so do not consume one of the hs_bndrs do { let (subst', tcb') = substTyConBinderX subst tcb - ; (tcbs', res) <- go subst' tcbs' hs_bndrs + ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb') + ; (tcbs', tvs, res) <- go subst' tcbs' hs_bndrs -- NB: pass on hs_bndrs unchanged; we do not consume a -- HsTyVarBndr for an invisible TyConBinder - ; return (tcb' : tcbs', res) } + ; return (tcb' : tcbs', tvs, res) } + -- Return `tvs`; no new lexically-scoped TyVars brought into scope | otherwise = -- At this point we conclude that: @@ -2726,14 +2743,19 @@ = return () tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind + ; traceTc "musd3:unifying" (ppr sig_kind $$ ppr expected_kind) ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } -- See GHC Proposal #425, section "Kind checking", -- where zippable and skippable are defined. + -- In particular: we match up if + -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified) + -- (b) HsBndr looks like a, and TyCon binder is forall k -> (NamedTCB Required) + -- or k -> (AnonTCB) zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool - zippable vis HsBndrRequired = isVisibleTcbVis vis - zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis + zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- (a) + zippable vis HsBndrRequired = isVisibleTcbVis vis -- (b) -- See GHC Proposal #425, section "Kind checking", -- where zippable and skippable are defined. @@ -3026,15 +3048,7 @@ checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () -- Check for duplicates --- E.g. data SameKind (a::k) (b::k) --- data T (a::k1) (b::k2) c = MkT (SameKind a b) c --- Here k1 and k2 start as TyVarTvs, and get unified with each other --- If this happens, things get very confused later, so fail fast --- --- In the CUSK case k1 and k2 are skolems so they won't unify; --- but in the inference case (see generaliseTcTyCon), --- and the type-sig case (see kcCheckDeclHeader_sig), they are --- TcTyVars, so we must check. +-- See Note [Aliasing in type and class declarations] checkForDuplicateScopedTyVars scoped_prs = unless (null err_prs) $ do { mapM_ report_dup err_prs; failM } @@ -3054,8 +3068,43 @@ addErrTc $ TcRnDifferentNamesForTyVar n1 n2 -{- Note [Disconnected type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Aliasing in type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data SameKind (a::k) (b::k) + data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c +We do not allow this, because `k1` and `k2` would both stand for the same type +variable -- they are both aliases for `k`. + +Other examples + data T2 (a::k1) = MkT2 (SameKind a Int) -- k1 stands for Type + data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b) -- k1 and k2 are aliases + + type UF :: forall zk. zk -> Constraint + class UF @kk (xb :: k) where -- kk and k are aliases + op :: (xs::kk) -> Bool + +See #24604 for an example that crashed GHC. + +There is a design choice here. It would be possible to allow implicit type variables +like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/. This is in fact +the rule we use in /terms/ pattern signatures: + f :: [Int] -> Int + f ((x::a) : xs) = ... +Here `a` stands for `Int`. But in type /signatures/ we make a different choice: + f1 :: forall (a::k1) (b::k2). SameKind a b -> blah + f2 :: forall (a::k). SameKind a Int -> blah + +Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is +rejected because `k` stands for `Int`. + +Our current choice is that type and class declarations behave more like signatures; +we do not allow aliasing. That is what `checkForDuplicateScopedTyVars` checks. +See !12328 for some design discussion. + + +Note [Disconnected type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This note applies when kind-checking the header of a type/class decl that has a separate, standalone kind signature. See #24083. @@ -3501,7 +3550,7 @@ | SMDSkolemTv SkolemInfo -smVanilla :: HasCallStack => SkolemMode +smVanilla :: HasDebugCallStack => SkolemMode smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this , sm_parent = False , sm_tvtv = pprPanic "sm_tvtv" callStackDoc -- We always override this 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 @@ -1197,6 +1197,9 @@ -- Getters and setters of GHC.Tc.Utils.Env fields -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +getUnifiedRef :: TcS (IORef Int) +getUnifiedRef = TcS (return . tcs_unified) + -- Getter of inerts and worklist getInertSetRef :: TcS (IORef InertSet) getInertSetRef = TcS (return . tcs_inerts) @@ -2001,7 +2004,8 @@ -- unified the process; the (Bag Ct) are the deferred constraints. wrapUnifierTcS ev role do_unifications - = do { (cos, unified, rewriters, cts) <- wrapTcS $ + = do { unif_count_ref <- getUnifiedRef + ; (cos, unified, rewriters, cts) <- wrapTcS $ do { defer_ref <- TcM.newTcRef emptyBag ; unified_ref <- TcM.newTcRef [] ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev) @@ -2015,6 +2019,13 @@ ; cts <- TcM.readTcRef defer_ref ; unified <- TcM.readTcRef unified_ref + + + -- Don't forget to update the count of variables + -- unified, lest we forget to iterate (#24146) + ; unless (null unified) $ + TcM.updTcRef unif_count_ref (+ (length unified)) + ; return (cos, unified, rewriters, cts) } -- Emit the deferred constraints diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1476,7 +1476,8 @@ ; return $ ListPat noAnn ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') } + ; let pp = parenthesizePat sigPrec p' + ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noAnn e' p'} 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.8.2.20240223 +version: 9.8.3.20241022 license: BSD-3-Clause license-file: LICENSE category: Development @@ -54,7 +54,7 @@ manual: True description: Pass -DTHREADED_RTS to the C toolchain library - default-language: Haskell2010 + default-language: Haskell2010 exposed: False include-dirs: rts/include @@ -62,6 +62,8 @@ ghc-lib/stage0/compiler/build compiler libraries/containers/containers/include + 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 cc-options: -DTHREADED_RTS @@ -79,10 +81,10 @@ containers >= 0.6.2.1 && < 0.7, bytestring >= 0.11.4 && < 0.13, time >= 1.4 && < 1.13, + filepath >= 1 && < 1.5, exceptions == 0.10.*, parsec, binary == 0.8.*, - filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.6, @@ -93,8 +95,8 @@ semaphore-compat, rts, hpc >= 0.6 && < 0.8, - ghc-lib-parser == 9.8.2.20240223 - build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 + ghc-lib-parser == 9.8.3.20241022 + build-tool-depends: alex:alex >= 3.1, happy:happy > 1.20 && < 2.0 other-extensions: BangPatterns CPP diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -2,7 +2,7 @@ ,("C compiler flags", "--target=x86_64-apple-darwin -Qunused-arguments") ,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ") -,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") +,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")