ghc-lib 9.10.1.20250421 → 9.10.2.20250503
raw patch · 82 files changed
+2143/−841 lines, 82 filesdep ~ghc-lib-parserdep ~ghc-prim
Dependency ranges changed: ghc-lib-parser, ghc-prim
Files
- compiler/GHC.hs +12/−7
- compiler/GHC/ByteCode/Asm.hs +16/−11
- compiler/GHC/ByteCode/Instr.hs +11/−4
- compiler/GHC/ByteCode/Linker.hs +53/−23
- compiler/GHC/Cmm/Dominators.hs +0/−1
- compiler/GHC/Cmm/Opt.hs +18/−1
- compiler/GHC/Cmm/ThreadSanitizer.hs +1/−2
- compiler/GHC/CmmToAsm/AArch64.hs +1/−0
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +298/−16
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +60/−9
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs +13/−3
- compiler/GHC/CmmToAsm/AArch64/Regs.hs +1/−0
- compiler/GHC/CmmToAsm/BlockLayout.hs +2/−3
- compiler/GHC/CmmToAsm/Instr.hs +7/−1
- compiler/GHC/CmmToAsm/Monad.hs +26/−0
- compiler/GHC/CmmToAsm/PPC.hs +1/−0
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +1/−1
- compiler/GHC/CmmToAsm/PPC/Instr.hs +8/−0
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−1
- compiler/GHC/CmmToAsm/Reg/Liveness.hs +5/−0
- compiler/GHC/CmmToAsm/X86.hs +1/−0
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +11/−7
- compiler/GHC/CmmToAsm/X86/Instr.hs +12/−0
- compiler/GHC/CmmToLlvm.hs +9/−8
- compiler/GHC/Core/LateCC.hs +6/−2
- compiler/GHC/Core/LateCC/TopLevelBinds.hs +31/−9
- compiler/GHC/Core/LateCC/Types.hs +1/−1
- compiler/GHC/Core/Opt/DmdAnal.hs +3/−3
- compiler/GHC/Core/Opt/SetLevels.hs +46/−15
- compiler/GHC/Core/Opt/SpecConstr.hs +17/−2
- compiler/GHC/Core/Opt/Specialise.hs +2/−1
- compiler/GHC/CoreToStg/Prep.hs +165/−72
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +35/−0
- compiler/GHC/Driver/Config/CoreToStg/Prep.hs +3/−7
- compiler/GHC/Driver/Config/StgToCmm.hs +8/−1
- compiler/GHC/Driver/Main.hs +2/−5
- compiler/GHC/Driver/Make.hs +29/−27
- compiler/GHC/Driver/Pipeline.hs +21/−21
- compiler/GHC/Driver/Pipeline/Execute.hs +9/−5
- compiler/GHC/Iface/Env.hs +2/−2
- compiler/GHC/Iface/Load.hs +0/−3
- compiler/GHC/Iface/Recomp/Flags.hs +18/−2
- compiler/GHC/Iface/Tidy.hs +5/−2
- compiler/GHC/Linker/Loader.hs +34/−26
- compiler/GHC/Linker/MacOS.hs +2/−2
- compiler/GHC/Rename/Env.hs +25/−1
- compiler/GHC/Rename/Module.hs +2/−0
- compiler/GHC/Rename/Pat.hs +2/−41
- compiler/GHC/Runtime/Eval.hs +66/−58
- compiler/GHC/Runtime/Interpreter.hs +84/−63
- compiler/GHC/Runtime/Interpreter/JS.hs +0/−3
- compiler/GHC/Settings/IO.hs +45/−9
- compiler/GHC/StgToByteCode.hs +50/−27
- compiler/GHC/StgToCmm/Foreign.hs +68/−8
- compiler/GHC/StgToCmm/InfoTableProv.hs +3/−4
- compiler/GHC/StgToCmm/Prim.hs +4/−3
- compiler/GHC/StgToJS/Linker/Linker.hs +82/−8
- compiler/GHC/StgToJS/Linker/Utils.hs +1/−1
- compiler/GHC/StgToJS/Literal.hs +18/−1
- compiler/GHC/StgToJS/Prim.hs +1/−1
- compiler/GHC/StgToJS/Rts/Rts.hs +6/−1
- compiler/GHC/SysTools/Cpp.hs +57/−17
- compiler/GHC/SysTools/Tasks.hs +72/−26
- compiler/GHC/Tc/Errors.hs +5/−46
- compiler/GHC/Tc/Gen/App.hs +6/−13
- compiler/GHC/Tc/Gen/Bind.hs +34/−12
- compiler/GHC/Tc/Gen/Head.hs +3/−41
- compiler/GHC/Tc/Gen/HsType.hs +24/−1
- compiler/GHC/Tc/Gen/Match.hs +35/−4
- compiler/GHC/Tc/Gen/Pat.hs +94/−39
- compiler/GHC/Tc/Instance/Family.hs +57/−1
- compiler/GHC/Tc/Module.hs +57/−11
- compiler/GHC/Tc/Solver/Equality.hs +11/−11
- compiler/GHC/Tc/Utils/Env.hs +43/−1
- compiler/GHC/Tc/Utils/Instantiate.hs +87/−13
- compiler/GHC/Tc/Utils/Monad.hs +17/−1
- compiler/GHC/Tc/Utils/Unify.hs +60/−60
- compiler/GHC/Tc/Zonk/Type.hs +4/−3
- compiler/GHC/ThToHs.hs +2/−1
- ghc-lib.cabal +4/−4
- ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +1/−1
- ghc-lib/stage0/lib/settings +5/−0
compiler/GHC.hs view
@@ -157,14 +157,14 @@ -- ** The debugger SingleStep(..), Resume(..),- History(historyBreakInfo, historyEnclosingDecls),+ History(historyBreakpointId, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, abandon, abandonAll, getResumeContext, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex,- BreakInfo(..),+ BreakpointId(..), InternalBreakpointId(..), GHC.Runtime.Eval.back, GHC.Runtime.Eval.forward, GHC.Runtime.Eval.setupBreakpoint,@@ -337,6 +337,7 @@ import GHC.Parser.Annotation import GHC.Parser.Utils +import GHC.Iface.Env ( trace_if ) import GHC.Iface.Load ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars )@@ -392,8 +393,9 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv-import GHC.Types.BreakInfo+import GHC.Types.Breakpoint import GHC.Types.PkgQual+import GHC.Types.Unique.FM import GHC.Unit import GHC.Unit.Env@@ -673,6 +675,7 @@ setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger+ lookup_cache <- liftIO $ newMVar emptyUFM -- Interpreter interp <- if@@ -702,7 +705,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)@@ -720,7 +723,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@@ -728,7 +731,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@@ -1701,6 +1704,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do+ liftIO $ trace_if (hsc_logger hsc_env) (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual) let mhome_unit = hsc_home_unit_maybe hsc_env let dflags = hsc_dflags hsc_env case pkgqual of@@ -1763,7 +1767,8 @@ lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)-lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->+lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> do+ liftIO $ trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid) case lookupHug (hsc_HUG hsc_env) uid mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing
compiler/GHC/ByteCode/Asm.hs view
@@ -71,9 +71,9 @@ where bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) = unionManyUniqDSets (- mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :- mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :- map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]+ mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] :+ mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :+ map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ] ) -- -----------------------------------------------------------------------------@@ -213,9 +213,9 @@ (text "bytecode instruction count mismatch") let asm_insns = ssElts final_insns- insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns- bitmap_arr = mkBitmapArray bsize bitmap- ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs+ !insns_arr = mkBCOByteArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns+ !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap+ ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSizedSeq final_lits) (fromSizedSeq final_ptrs) -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until@@ -224,7 +224,7 @@ return ul_bco -mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64+mkBitmapArray :: Word -> [StgWord] -> UArray Int Word -- Here the return type must be an array of Words, not StgWords, -- because the underlying ByteArray# will end up as a component -- of a BCO object.@@ -513,11 +513,16 @@ CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit bci_PRIMCALL []- BRK_FUN arr index mod cc -> do p1 <- ptr (BCOPtrBreakArray arr)- m <- addr mod+ BRK_FUN arr tick_mod tickx info_mod infox cc ->+ do p1 <- ptr (BCOPtrBreakArray arr)+ tick_addr <- addr tick_mod+ info_addr <- addr info_mod np <- addr cc- emit bci_BRK_FUN [Op p1, SmallOp index,- Op m, Op np]+ emit bci_BRK_FUN [ Op p1+ , Op tick_addr, Op info_addr+ , SmallOp tickx, SmallOp infox+ , Op np+ ] where literal (LitLabel fs (Just sz) _)
compiler/GHC/ByteCode/Instr.hs view
@@ -83,7 +83,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)@@ -206,7 +206,11 @@ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints- | BRK_FUN (ForeignRef BreakArray) !Word16 (RemotePtr ModuleName)+ | BRK_FUN (ForeignRef BreakArray)+ (RemotePtr ModuleName) -- breakpoint tick module+ !Word16 -- breakpoint tick index+ (RemotePtr ModuleName) -- breakpoint info module+ !Word16 -- breakpoint info index (RemotePtr CostCentre) -- -----------------------------------------------------------------------------@@ -358,8 +362,11 @@ ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE"- ppr (BRK_FUN _ index _ _) = text "BRK_FUN" <+> text "<breakarray>"- <+> ppr index <+> text "<module>" <+> text "<cc>"+ ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)+ = text "BRK_FUN" <+> text "<breakarray>"+ <+> text "<tick_module>" <+> ppr tickx+ <+> text "<info_module>" <+> ppr infox+ <+> text "<cc>"
compiler/GHC/ByteCode/Linker.hs view
@@ -24,6 +24,7 @@ import GHCi.ResolvedBCO import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names import GHC.Unit.Types@@ -38,6 +39,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 @@ -52,31 +55,35 @@ linkBCO :: Interp+ -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO-linkBCO interp le bco_ix+linkBCO interp pkgs_loaded le bco_ix (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) (ssElts ptrs0)- return (ResolvedBCO isLittleEndian arity insns bitmap- (listArray (0, fromIntegral (sizeSS lits0)-1) lits)+ (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)+ ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)+ let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits+ return (ResolvedBCO isLittleEndian arity+ insns+ bitmap+ (mkBCOByteArray 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@@ -90,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"@@ -110,34 +117,35 @@ 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 -> BCOPtr -> IO ResolvedBCOPtr-resolvePtr interp le bco_ix ptr = case ptr of+resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group@@ -149,19 +157,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 bco+ -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco BCOPtrBreakArray breakarray -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)++-- | 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
compiler/GHC/Cmm/Dominators.hs view
@@ -23,7 +23,6 @@ import GHC.Prelude import Data.Array.IArray-import Data.Foldable() import qualified Data.Tree as Tree import Data.Word
compiler/GHC/Cmm/Opt.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Cmm/ThreadSanitizer.hs view
@@ -184,7 +184,7 @@ restore = blockFromList restore_nodes -- | Mirrors __tsan_memory_order--- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32>+-- <https://github.com/llvm/llvm-project/blob/main/compiler-rt/include/sanitizer/tsan_interface_atomic.h#L34> memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr memoryOrderToTsanMemoryOrder env mord = mkIntExpr (platform env) n@@ -294,4 +294,3 @@ AMO_Or -> "fetch_or" AMO_Xor -> "fetch_xor" fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op'-
compiler/GHC/CmmToAsm/AArch64.hs view
@@ -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
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1556,7 +1556,7 @@ -- pprTraceM "genCCall target" (ppr target) -- pprTraceM "genCCall formal" (ppr dest_regs) -- pprTraceM "genCCall actual" (ppr arg_regs)-+ platform <- getPlatform case target of -- The target :: ForeignTarget call can either -- be a foreign procedure with an address expr@@ -1584,7 +1584,6 @@ let (_res_hints, arg_hints) = foreignTargetHints target arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints - platform <- getPlatform let packStack = platformOS platform == OSDarwin (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL@@ -1595,7 +1594,7 @@ then 8 * (stackSpace' `div` 8 + 1) else stackSpace' - (returnRegs, readResultsCode) <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL+ readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL let moveStackDown 0 = toOL [ PUSH_STACK_FRAME , DELTA (-16) ]@@ -1613,7 +1612,7 @@ let code = call_target_code -- compute the label (possibly into a register) `appOL` moveStackDown (stackSpace `div` 8) `appOL` passArgumentsCode -- put the arguments into x0, ...- `appOL` (unitOL $ BL call_target passRegs returnRegs) -- branch and link.+ `appOL` (unitOL $ BL call_target passRegs) -- branch and link. `appOL` readResultsCode -- parse the results into registers `appOL` moveStackUp (stackSpace `div` 8) return (code, Nothing)@@ -1621,10 +1620,303 @@ PrimTarget MO_F32_Fabs | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+ | otherwise -> panic "mal-formed MO_F32_Fabs" PrimTarget MO_F64_Fabs | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+ | otherwise -> panic "mal-formed MO_F64_Fabs"+ PrimTarget MO_F32_Sqrt+ | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+ unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+ | otherwise -> panic "mal-formed MO_F32_Sqrt"+ PrimTarget MO_F64_Sqrt+ | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+ unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+ | otherwise -> panic "mal-formed MO_F64_Sqrt" ++ PrimTarget (MO_S_Mul2 w)+ -- Life is easier when we're working with word sized operands,+ -- we can use SMULH to compute the high 64 bits, and dst_needed+ -- checks if the high half's bits are all the same as the low half's+ -- top bit.+ | w == W64+ , [src_a, src_b] <- arg_regs+ -- dst_needed = did the result fit into just the low half+ , [dst_needed, dst_hi, dst_lo] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src_a+ (reg_b, _format_y, code_y) <- getSomeReg src_b++ let lo = getRegisterReg platform (CmmLocal dst_lo)+ hi = getRegisterReg platform (CmmLocal dst_hi)+ nd = getRegisterReg platform (CmmLocal dst_needed)+ return (+ code_x `appOL`+ code_y `snocOL`+ MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+ SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+ -- Are all high bits equal to the sign bit of the low word?+ -- nd = (hi == ASR(lo,width-1)) ? 1 : 0+ CMP (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`+ CSET (OpReg W64 nd) NE+ , Nothing)+ -- For sizes < platform width, we can just perform a multiply and shift+ -- using the normal 64 bit multiply. Calculating the dst_needed value is+ -- complicated a little by the need to be careful when truncation happens.+ -- Currently this case can't be generated since+ -- timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #)+ -- TODO: Should this be removed or would other primops be useful?+ | w < W64+ , [src_a, src_b] <- arg_regs+ , [dst_needed, dst_hi, dst_lo] <- dest_regs+ -> do+ (reg_a', _format_x, code_a) <- getSomeReg src_a+ (reg_b', _format_y, code_b) <- getSomeReg src_b++ let lo = getRegisterReg platform (CmmLocal dst_lo)+ hi = getRegisterReg platform (CmmLocal dst_hi)+ nd = getRegisterReg platform (CmmLocal dst_needed)+ -- Do everything in a full 64 bit registers+ w' = platformWordWidth platform++ (reg_a, code_a') <- signExtendReg w w' reg_a'+ (reg_b, code_b') <- signExtendReg w w' reg_b'++ return (+ code_a `appOL`+ code_b `appOL`+ code_a' `appOL`+ code_b' `snocOL`+ -- the low 2w' of lo contains the full multiplication;+ -- eg: int8 * int8 -> int16 result+ -- so lo is in the last w of the register, and hi is in the second w.+ SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`+ -- Make sure we hold onto the sign bits for dst_needed+ ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL`+ -- lo can now be truncated so we can get at it's top bit easily.+ truncateReg w' w lo `snocOL`+ -- Note the use of CMN (compare negative), not CMP: we want to+ -- test if the top half is negative one and the top+ -- bit of the bottom half is positive one. eg:+ -- hi = 0b1111_1111 (actually 64 bits)+ -- lo = 0b1010_1111 (-81, so the result didn't need the top half)+ -- lo' = ASR(lo,7) (second reg of SMN)+ -- = 0b0000_0001 (theeshift gives us 1 for negative,+ -- and 0 for positive)+ -- hi == -lo'?+ -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow)+ -- Another way to think of this is if hi + lo' == 0, which is what+ -- CMN really is under the hood.+ CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`+ -- Set dst_needed to 1 if hi and lo' were (negatively) equal+ CSET (OpReg w' nd) EQ `appOL`+ -- Finally truncate hi to drop any extraneous sign bits.+ truncateReg w' w hi+ , Nothing)+ -- Can't handle > 64 bit operands+ | otherwise -> unsupported (MO_S_Mul2 w)+ PrimTarget (MO_U_Mul2 w)+ -- The unsigned case is much simpler than the signed, all we need to+ -- do is the multiplication straight into the destination registers.+ | w == W64+ , [src_a, src_b] <- arg_regs+ , [dst_hi, dst_lo] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src_a+ (reg_b, _format_y, code_y) <- getSomeReg src_b++ let lo = getRegisterReg platform (CmmLocal dst_lo)+ hi = getRegisterReg platform (CmmLocal dst_hi)+ return (+ code_x `appOL`+ code_y `snocOL`+ MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+ UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b)+ , Nothing)+ -- For sizes < platform width, we can just perform a multiply and shift+ -- Need to be careful to truncate the low half, but the upper half should be+ -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.+ -- Currently this case can't be produced by the compiler since+ -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #)+ -- TODO: Remove? Or would the extra primop be useful for avoiding the extra+ -- steps needed to do this in userland?+ | w < W64+ , [src_a, src_b] <- arg_regs+ , [dst_hi, dst_lo] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src_a+ (reg_b, _format_y, code_y) <- getSomeReg src_b++ let lo = getRegisterReg platform (CmmLocal dst_lo)+ hi = getRegisterReg platform (CmmLocal dst_hi)+ w' = opRegWidth w+ return (+ code_x `appOL`+ code_y `snocOL`+ -- UMULL: Xd = Wa * Wb with 64 bit result+ -- W64 inputs should have been caught by case above+ UMULL (OpReg W64 lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`+ -- Extract and truncate high result+ -- hi[w:0] = lo[2w:w]+ UBFX (OpReg W64 hi) (OpReg W64 lo)+ (OpImm (ImmInt $ widthInBits w)) -- lsb+ (OpImm (ImmInt $ widthInBits w)) -- width to extract+ `appOL`+ truncateReg W64 w lo+ , Nothing)+ | otherwise -> unsupported (MO_U_Mul2 w)+ PrimTarget (MO_Clz w)+ | w == W64 || w == W32+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst_reg = getRegisterReg platform (CmmLocal dst)+ return (+ code_x `snocOL`+ CLZ (OpReg w dst_reg) (OpReg w reg_a)+ , Nothing)+ | w == W16+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ imm n = OpImm (ImmInt n)+ {- dst = clz(x << 16 | 0x0000_8000) -}+ return (+ code_x `appOL` toOL+ [ LSL (r dst') (r reg_a) (imm 16)+ , ORR (r dst') (r dst') (imm 0x00008000)+ , CLZ (r dst') (r dst')+ ]+ , Nothing)+ | w == W8+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ imm n = OpImm (ImmInt n)+ {- dst = clz(x << 24 | 0x0080_0000) -}+ return (+ code_x `appOL` toOL+ [ LSL (r dst') (r reg_a) (imm 24)+ , ORR (r dst') (r dst') (imm 0x00800000)+ , CLZ (r dst') (r dst')+ ]+ , Nothing)+ | otherwise -> unsupported (MO_Clz w)+ PrimTarget (MO_Ctz w)+ | w == W64 || w == W32+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst_reg = getRegisterReg platform (CmmLocal dst)+ return (+ code_x `snocOL`+ RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL`+ CLZ (OpReg w dst_reg) (OpReg w dst_reg)+ , Nothing)+ | w == W16+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ imm n = OpImm (ImmInt n)+ {- dst = clz(reverseBits(x) | 0x0000_8000) -}+ return (+ code_x `appOL` toOL+ [ RBIT (r dst') (r reg_a)+ , ORR (r dst') (r dst') (imm 0x00008000)+ , CLZ (r dst') (r dst')+ ]+ , Nothing)+ | w == W8+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ imm n = OpImm (ImmInt n)+ {- dst = clz(reverseBits(x) | 0x0080_0000) -}+ return (+ code_x `appOL` toOL+ [ RBIT (r dst') (r reg_a)+ , ORR (r dst') (r dst') (imm 0x00800000)+ , CLZ (r dst') (r dst')+ ]+ , Nothing)+ | otherwise -> unsupported (MO_Ctz w)+ PrimTarget (MO_BRev w)+ | w == W64 || w == W32+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst_reg = getRegisterReg platform (CmmLocal dst)+ return (+ code_x `snocOL`+ RBIT (OpReg w dst_reg) (OpReg w reg_a)+ , Nothing)+ | w == W16+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ imm n = OpImm (ImmInt n)+ {- dst = reverseBits32(x << 16) -}+ return (+ code_x `appOL` toOL+ [ LSL (r dst') (r reg_a) (imm 16)+ , RBIT (r dst') (r dst')+ ]+ , Nothing)+ | w == W8+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ imm n = OpImm (ImmInt n)+ {- dst = reverseBits32(x << 24) -}+ return (+ code_x `appOL` toOL+ [ LSL (r dst') (r reg_a) (imm 24)+ , RBIT (r dst') (r dst')+ ]+ , Nothing)+ | otherwise -> unsupported (MO_BRev w)+ PrimTarget (MO_BSwap w)+ | w == W64 || w == W32+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst_reg = getRegisterReg platform (CmmLocal dst)+ return $ (code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a), Nothing)+ | w == W16+ , [src] <- arg_regs+ , [dst] <- dest_regs+ -> do+ (reg_a, _format_x, code_x) <- getSomeReg src+ let dst' = getRegisterReg platform (CmmLocal dst)+ r n = OpReg W32 n+ -- Swaps the bytes in each 16bit word+ -- TODO: Expose the 32 & 64 bit version of this?+ return $ (code_x `snocOL` REV16 (r dst') (r reg_a), Nothing)+ | otherwise -> unsupported (MO_BSwap w)+ -- or a possibly side-effecting machine operation -- mop :: CallishMachOp (see GHC.Cmm.MachOp) PrimTarget mop -> do@@ -1653,8 +1945,6 @@ MO_F64_Log1P -> mkCCall "log1p" MO_F64_Exp -> mkCCall "exp" MO_F64_ExpM1 -> mkCCall "expm1"- MO_F64_Fabs -> mkCCall "fabs"- MO_F64_Sqrt -> mkCCall "sqrt" -- 32 bit float ops MO_F32_Pwr -> mkCCall "powf"@@ -1675,8 +1965,6 @@ MO_F32_Log1P -> mkCCall "log1pf" MO_F32_Exp -> mkCCall "expf" MO_F32_ExpM1 -> mkCCall "expm1f"- MO_F32_Fabs -> mkCCall "fabsf"- MO_F32_Sqrt -> mkCCall "sqrtf" -- 64-bit primops MO_I64_ToI -> mkCCall "hs_int64ToInt"@@ -1714,7 +2002,6 @@ -- Arithmatic -- These are not supported on X86, so I doubt they are used much.- MO_S_Mul2 _w -> unsupported mop MO_S_QuotRem _w -> unsupported mop MO_U_QuotRem _w -> unsupported mop MO_U_QuotRem2 _w -> unsupported mop@@ -1723,7 +2010,6 @@ MO_SubWordC _w -> unsupported mop MO_AddIntC _w -> unsupported mop MO_SubIntC _w -> unsupported mop- MO_U_Mul2 _w -> unsupported mop -- Memory Ordering MO_AcquireFence -> return (unitOL DMBISH, Nothing)@@ -1751,10 +2037,6 @@ MO_PopCnt w -> mkCCall (popCntLabel w) MO_Pdep w -> mkCCall (pdepLabel w) MO_Pext w -> mkCCall (pextLabel w)- MO_Clz w -> mkCCall (clzLabel w)- MO_Ctz w -> mkCCall (ctzLabel w)- MO_BSwap w -> mkCCall (bSwapLabel w)- MO_BRev w -> mkCCall (bRevLabel w) -- -- Atomic read-modify-write. MO_AtomicRead w ord@@ -1943,8 +2225,8 @@ passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") - readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)- readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode)+ readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock)+ readResults _ _ [] _ accumCode = return accumCode readResults [] _ _ _ _ = do platform <- getPlatform pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -79,11 +79,14 @@ -- 1. Arithmetic Instructions ------------------------------------------------ ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) CMP l r -> usage (regOp l ++ regOp r, [])+ CMN l r -> usage (regOp l ++ regOp r, []) MSUB dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) NEG dst src -> usage (regOp src, regOp dst) SMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+ UMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+ UMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) UDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)@@ -97,6 +100,11 @@ UXTB dst src -> usage (regOp src, regOp dst) SXTH dst src -> usage (regOp src, regOp dst) UXTH dst src -> usage (regOp src, regOp dst)+ CLZ dst src -> usage (regOp src, regOp dst)+ RBIT dst src -> usage (regOp src, regOp dst)+ REV dst src -> usage (regOp src, regOp dst)+ -- REV32 dst src -> usage (regOp src, regOp dst)+ REV16 dst src -> usage (regOp src, regOp dst) -- 3. Logical and Move Instructions ------------------------------------------ AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) ASR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)@@ -112,7 +120,7 @@ J t -> usage (regTarget t, []) B t -> usage (regTarget t, []) BCOND _ t -> usage (regTarget t, [])- BL t ps _rs -> usage (regTarget t ++ ps, callerSavedRegisters)+ BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) -- 5. Atomic Instructions ---------------------------------------------------- -- 6. Conditional Instructions -----------------------------------------------@@ -133,10 +141,12 @@ SCVTF dst src -> usage (regOp src, regOp dst) FCVTZS dst src -> usage (regOp src, regOp dst) FABS dst src -> usage (regOp src, regOp dst)+ FSQRT dst src -> usage (regOp src, regOp dst) FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) - _ -> panic $ "regUsageOfInstr: " ++ instrCon instr+ LOCATION{} -> panic $ "regUsageOfInstr: " ++ instrCon instr+ NEWBLOCK{} -> panic $ "regUsageOfInstr: " ++ instrCon instr where -- filtering the usage is necessary, otherwise the register@@ -167,6 +177,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 --@@ -189,6 +201,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]@@ -209,11 +223,14 @@ -- 1. Arithmetic Instructions ---------------------------------------------- ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) CMP o1 o2 -> CMP (patchOp o1) (patchOp o2)+ CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2) (patchOp o3) SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2) (patchOp o3)+ UMULH o1 o2 o3 -> UMULH (patchOp o1) (patchOp o2) (patchOp o3)+ UMULL o1 o2 o3 -> UMULL (patchOp o1) (patchOp o2) (patchOp o3) SDIV o1 o2 o3 -> SDIV (patchOp o1) (patchOp o2) (patchOp o3) SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) UDIV o1 o2 o3 -> UDIV (patchOp o1) (patchOp o2) (patchOp o3)@@ -227,7 +244,13 @@ UXTB o1 o2 -> UXTB (patchOp o1) (patchOp o2) SXTH o1 o2 -> SXTH (patchOp o1) (patchOp o2) UXTH o1 o2 -> UXTH (patchOp o1) (patchOp o2)+ CLZ o1 o2 -> CLZ (patchOp o1) (patchOp o2)+ RBIT o1 o2 -> RBIT (patchOp o1) (patchOp o2)+ REV o1 o2 -> REV (patchOp o1) (patchOp o2)+ -- REV32 o1 o2 -> REV32 (patchOp o1) (patchOp o2)+ REV16 o1 o2 -> REV16 (patchOp o1) (patchOp o2) + -- 3. Logical and Move Instructions ---------------------------------------- AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) ASR o1 o2 o3 -> ASR (patchOp o1) (patchOp o2) (patchOp o3)@@ -243,7 +266,7 @@ -- 4. Branch Instructions -------------------------------------------------- J t -> J (patchTarget t) B t -> B (patchTarget t)- BL t rs ts -> BL (patchTarget t) rs ts+ BL t rs -> BL (patchTarget t) rs BCOND c t -> BCOND c (patchTarget t) -- 5. Atomic Instructions --------------------------------------------------@@ -265,10 +288,12 @@ SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)+ FSQRT o1 o2 -> FSQRT (patchOp o1) (patchOp o2) FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) - _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr+ NEWBLOCK{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr+ LOCATION{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand patchOp (OpReg w r) = OpReg w (env r)@@ -307,10 +332,16 @@ jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]-jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]]+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 -- points.@@ -322,7 +353,7 @@ CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid)) J (TBlock bid) -> J (TBlock (patchF bid)) B (TBlock bid) -> B (TBlock (patchF bid))- BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs+ BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid)) _ -> panic $ "patchJumpInstr: " ++ instrCon instr @@ -540,6 +571,7 @@ -- | ADR ... -- | ADRP ... | CMP Operand Operand -- rd - op2+ | CMN Operand Operand -- rd + op2 -- | MADD ... -- | MNEG ... | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm@@ -562,8 +594,8 @@ -- | UMADDL ... -- Xd = Xa + Wn × Wm -- | UMNEGL ... -- Xd = - Wn × Wm -- | UMSUBL ... -- Xd = Xa - Wn × Wm- -- | UMULH ... -- Xd = (Xn × Xm)_127:64- -- | UMULL ... -- Xd = Wn × Wm+ | UMULH Operand Operand Operand -- Xd = (Xn × Xm)_127:64+ | UMULL Operand Operand Operand -- Xd = Wn × Wm -- 2. Bit Manipulation Instructions ---------------------------------------- | SBFM Operand Operand Operand Operand -- rd = rn[i,j]@@ -576,6 +608,14 @@ -- Signed/Unsigned bitfield extract | SBFX Operand Operand Operand Operand -- rd = rn[i,j] | UBFX Operand Operand Operand Operand -- rd = rn[i,j]+ | CLZ Operand Operand -- rd = countLeadingZeros(rn)+ | RBIT Operand Operand -- rd = reverseBits(rn)+ | REV Operand Operand -- rd = reverseBytes(rn): (for 32 & 64 bit operands)+ -- 0xAABBCCDD -> 0xDDCCBBAA+ | REV16 Operand Operand -- rd = reverseBytes16(rn)+ -- 0xAABB_CCDD -> xBBAA_DDCC+ -- | REV32 Operand Operand -- rd = reverseBytes32(rn) - 64bit operands only!+ -- -- 0xAABBCCDD_EEFFGGHH -> 0XDDCCBBAA_HHGGFFEE -- 3. Logical and Move Instructions ---------------------------------------- | AND Operand Operand Operand -- rd = rn & op2@@ -604,7 +644,7 @@ -- Branching. | J Target -- like B, but only generated from genJump. Used to distinguish genJumps from others. | B Target -- unconditional branching b/br. (To a blockid, label or register)- | BL Target [Reg] [Reg] -- branch and link (e.g. set x30 to next pc, and branch)+ | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch) | BCOND Cond Target -- branch with condition. b.<cond> -- 8. Synchronization Instructions -----------------------------------------@@ -618,6 +658,8 @@ | FCVTZS Operand Operand -- Float ABSolute value | FABS Operand Operand+ -- Float SQuare RooT+ | FSQRT Operand Operand -- | Floating-point fused multiply-add instructions --@@ -644,18 +686,26 @@ POP_STACK_FRAME{} -> "POP_STACK_FRAME" ADD{} -> "ADD" CMP{} -> "CMP"+ CMN{} -> "CMN" MSUB{} -> "MSUB" MUL{} -> "MUL" NEG{} -> "NEG" SDIV{} -> "SDIV" SMULH{} -> "SMULH" SMULL{} -> "SMULL"+ UMULH{} -> "UMULH"+ UMULL{} -> "UMULL" SUB{} -> "SUB" UDIV{} -> "UDIV" SBFM{} -> "SBFM" UBFM{} -> "UBFM" SBFX{} -> "SBFX" UBFX{} -> "UBFX"+ CLZ{} -> "CLZ"+ RBIT{} -> "RBIT"+ REV{} -> "REV"+ REV16{} -> "REV16"+ -- REV32{} -> "REV32" AND{} -> "AND" ASR{} -> "ASR" EOR{} -> "EOR"@@ -682,6 +732,7 @@ SCVTF{} -> "SCVTF" FCVTZS{} -> "FCVTZS" FABS{} -> "FABS"+ FSQRT{} -> "FSQRT" FMA variant _ _ _ _ -> case variant of FMAdd -> "FMADD"
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -316,6 +316,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"@@ -372,12 +373,15 @@ CMP o1 o2 | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2 | otherwise -> op2 (text "\tcmp") o1 o2+ CMN o1 o2 -> op2 (text "\tcmn") o1 o2 MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4 MUL o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul") o1 o2 o3 | otherwise -> op3 (text "\tmul") o1 o2 o3 SMULH o1 o2 o3 -> op3 (text "\tsmulh") o1 o2 o3 SMULL o1 o2 o3 -> op3 (text "\tsmull") o1 o2 o3+ UMULH o1 o2 o3 -> op3 (text "\tumulh") o1 o2 o3+ UMULL o1 o2 o3 -> op3 (text "\tumull") o1 o2 o3 NEG o1 o2 | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2 | otherwise -> op2 (text "\tneg") o1 o2@@ -393,6 +397,11 @@ -- 2. Bit Manipulation Instructions ------------------------------------------ SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4 UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4+ CLZ o1 o2 -> op2 (text "\tclz") o1 o2+ RBIT o1 o2 -> op2 (text "\trbit") o1 o2+ REV o1 o2 -> op2 (text "\trev") o1 o2+ REV16 o1 o2 -> op2 (text "\trev16") o1 o2+ -- REV32 o1 o2 -> op2 (text "\trev32") o1 o2 -- signed and unsigned bitfield extract SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4 UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4@@ -421,9 +430,9 @@ B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r - BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))- BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl- BL (TReg r) _ _ -> line $ text "\tblr" <+> pprReg W64 r+ BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+ BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl+ BL (TReg r) _ -> line $ text "\tblr" <+> pprReg W64 r BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl@@ -525,6 +534,7 @@ SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2 FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2 FABS o1 o2 -> op2 (text "\tfabs") o1 o2+ FSQRT o1 o2 -> op2 (text "\tfsqrt") o1 o2 FMA variant d r1 r2 r3 -> let fma = case variant of FMAdd -> text "\tfmadd"
compiler/GHC/CmmToAsm/AArch64/Regs.hs view
@@ -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.
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -771,10 +771,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
compiler/GHC/CmmToAsm/Instr.hs view
@@ -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.
compiler/GHC/CmmToAsm/Monad.hs view
@@ -78,8 +78,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.@@ -104,6 +111,25 @@ -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@ -- 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/CmmToAsm/PPC.hs view
@@ -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
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -1770,7 +1770,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)
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -22,6 +22,7 @@ , patchJumpInstr , patchRegsOfInstr , jumpDestsOfInstr+ , canFallthroughTo , takeRegRegMoveInstr , takeDeltaInstr , mkRegRegMoveInstr@@ -508,6 +509,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.
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -183,7 +183,8 @@ ArchPPC -> 26 ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM"- ArchAArch64 -> 28 -- 32 - D1..D4+ 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"
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -126,6 +126,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
compiler/GHC/CmmToAsm/X86.hs view
@@ -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
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -2660,10 +2660,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@@ -2817,10 +2818,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@@ -3058,9 +3060,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
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -31,6 +31,7 @@ , mkSpillInstr , mkRegRegMoveInstr , jumpDestsOfInstr+ , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr@@ -669,6 +670,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
compiler/GHC/CmmToLlvm.hs view
@@ -11,7 +11,7 @@ ) where -import GHC.Prelude hiding ( head )+import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base@@ -38,8 +38,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 -- -----------------------------------------------------------------------------@@ -69,11 +68,13 @@ "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..."- let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X- let major_ver = head . llvmVersionNE $ ver- when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $- "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>- "You are using LLVM version: " <> text (llvmVersionStr ver)++ when (isNothing mb_ver) $ do+ let doWarn = llvmCgDoWarn cfg+ when doWarn $ putMsg logger $+ "Failed to detect LLVM version!" $$+ "Make sure LLVM is installed correctly." $$+ "We will try though..." -- HACK: the Nothing case here is potentially wrong here but we -- currently don't use the LLVM version to guide code generation
compiler/GHC/Core/LateCC.hs view
@@ -21,6 +21,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Outputable+import GHC.Types.RepType (mightBeFunTy) -- | Late cost center insertion logic used by the driver addLateCostCenters ::@@ -78,8 +79,11 @@ top_level_cc_pred :: CoreExpr -> Bool top_level_cc_pred = case lateCCConfig_whichBinds of- LateCCAllBinds ->- const True+ LateCCBinds -> \rhs ->+ -- Make sure we record any functions. Even if it's something like `f = g`.+ mightBeFunTy (exprType rhs) ||+ -- If the RHS is a CAF doing work also insert a CC.+ not (exprIsWorkFree rhs) LateCCOverloadedBinds -> isOverloadedTy . exprType LateCCNone ->
compiler/GHC/Core/LateCC/TopLevelBinds.hs view
@@ -3,16 +3,18 @@ import GHC.Prelude -import GHC.Core--- import GHC.Core.LateCC import GHC.Core.LateCC.Types import GHC.Core.LateCC.Utils++import GHC.Core import GHC.Core.Opt.Monad import GHC.Driver.DynFlags import GHC.Types.Id import GHC.Types.Name import GHC.Unit.Module.ModGuts +import Data.Maybe+ {- Note [Collecting late cost centres] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Usually cost centres defined by a module are collected@@ -26,7 +28,7 @@ Note [Adding late cost centres to top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea is very simple. For every top level binder+The basic idea is very simple. For a top level binder `f = rhs` we compile it as if the user had written `f = {-# SCC f #-} rhs`. @@ -37,6 +39,21 @@ we provide flags for both approaches as they have different tradeoffs. +To reduce overhead we ignore workfree bindings because they don't contribute+meaningfully to a performance profile. This reduces code size massively as it+allows us to allocate definitions like `val = Just 32` at compile time instead+of turning them into a CAF of the form `val = <scc val> let x = Just 32 in x` which+would be the alternative.++We make an exception for rhss with function types. This allows us to get+cost centres on eta-reduced definitions like `f = g`. By putting a tick onto+`f`s rhs we end up with++ f = \eta1 eta2 ... etan ->+ <scc f> g eta1 ... etan++Which can make it easier to understand call graphs of an application.+ We also don't add a cost centre for any binder that is a constructor worker or wrapper. These will never meaningfully enrich the resulting profile so we improve efficiency by omitting those.@@ -89,15 +106,20 @@ doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr doBndr bndr rhs- -- Cost centres on constructor workers are pretty much useless- -- so we don't emit them if we are looking at the rhs of a constructor- -- binding.- | Just _ <- isDataConId_maybe bndr = pure rhs- | otherwise = if pred rhs then addCC bndr rhs else pure rhs+ -- Not a constructor worker.+ -- Cost centres on constructor workers are pretty much useless so we don't emit them+ -- if we are looking at the rhs of a constructor binding.+ | isNothing (isDataConId_maybe bndr)+ , pred rhs+ = addCC bndr rhs+ | otherwise = pure rhs -- We want to put the cost centre below the lambda as we only care about- -- executions of the RHS.+ -- executions of the RHS. Note that the lambdas might be hidden under ticks+ -- or casts. So look through these as well. addCC :: Id -> CoreExpr -> LateCCM s CoreExpr+ addCC bndr (Cast rhs co) = pure Cast <*> addCC bndr rhs <*> pure co+ addCC bndr (Tick t rhs) = (Tick t) <$> addCC bndr rhs addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs addCC bndr rhs = do let name = idName bndr
compiler/GHC/Core/LateCC/Types.hs view
@@ -34,7 +34,7 @@ -- | The types of top-level bindings we support adding cost centers to. data LateCCBindSpec = LateCCNone- | LateCCAllBinds+ | LateCCBinds | LateCCOverloadedBinds -- | Late cost centre insertion environment
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -1028,10 +1028,10 @@ TopLevel | isInterestingTopLevelFn var -- Top-level things will be used multiple times or not at- -- all anyway, hence the multDmd below: It means we don't+ -- all anyway, hence the `floatifyDmd`: it means we don't -- have to track whether @var@ is used strictly or at most- -- once, because ultimately it never will.- -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness+ -- once, because ultimately it never will+ -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd)) | otherwise -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later -- Everything else:
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -991,6 +991,11 @@ as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot argument. + Do /not/ do this for bottoming /join-point/ bindings. They may call other+ join points (#24768), and floating to the top would abstract over those join+ points, which we should never do.++ See Maessen's paper 1999 "Bottom extraction: factoring error handling out of functional programs" (unpublished I think). @@ -1188,9 +1193,11 @@ deann_rhs = deAnnotate rhs mb_bot_str = exprBotStrictness_maybe deann_rhs- is_bot_lam = isJust mb_bot_str+ is_bot_lam = not is_join && isJust mb_bot_str -- is_bot_lam: looks like (\xy. bot), maybe zero lams- -- NB: not isBottomThunk! See Note [Bottoming floats] point (3)+ -- NB: not isBottomThunk!+ -- NB: not is_join: don't send bottoming join points to the top.+ -- See Note [Bottoming floats] point (3) n_extra = count isId abs_vars mb_join_arity = idJoinPointHood bndr@@ -1809,7 +1816,6 @@ env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) dest_lvl vs = do { let vs1 = map zap vs- -- See Note [Zapping the demand info] ; (subst', vs2) <- case is_rec of NonRecursive -> cloneBndrs subst vs1 Recursive -> cloneRecIdBndrs subst vs1@@ -1822,9 +1828,12 @@ ; return (env', vs2) } where zap :: Var -> Var- zap v | isId v = zap_join (zapIdDemandInfo v)+ -- See Note [Floatifying demand info when floating]+ -- and Note [Zapping JoinId when floating]+ zap v | isId v = zap_join (floatifyIdDemandInfo v) | otherwise = v + -- See Note [Zapping JoinId when floating] zap_join | isTopLvl dest_lvl = zapJoinId | otherwise = id @@ -1833,16 +1842,38 @@ | isTyVar v = delVarEnv id_env v | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1) -{--Note [Zapping the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-VERY IMPORTANT: we must zap the demand info if the thing is going to-float out, because it may be less demanded than at its original-binding site. Eg- f :: Int -> Int- f x = let v = 3*4 in v+x-Here v is strict; but if we float v to top level, it isn't any more.+{- Note [Zapping JoinId when floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we are floating a join point, it won't be one anymore, so we zap+the join point information. -Similarly, if we're floating a join point, it won't be one anymore, so we zap-join point information as well.+Note [Floatifying demand info when floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When floating we must lazify the outer demand info on the Id+because it may be less demanded than at its original binding site.+For example:+ f :: Int -> Int+ f x = let v = 3*4 in v+x+Here v is strict and used at most once; but if we float v to top level,+that isn't true any more. Specifically, we lose track of v's cardinality info:+ * if `f` is called multiple times, then `v` is used more than once+ * if `f` is never called, then `v` is never evaluated.++But NOTE that we only need to adjust the /top-level/ cardinality info.+For example+ let x = (e1,e2)+ in ...(case x of (a,b) -> a+b)...+If we float x outwards, it may no longer be strict, but IF it is ever+evaluated THEN its components will be evaluated. So we to lazify and+many-ify its demand-info, not discard it entirely.++Same if we have+ let f = \x y . blah+ in ...(f a b)...(f c d)...+Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can+keep that `1C` called-once inner demand. It's only the outer strictness+that we kill.++Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the+fact that `v` may be used any number of times, from zero upwards. -}
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -639,6 +639,17 @@ representing strict fields. See Note [Call-by-value for worker args] for why we do this. +(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944).+ We don't want to make+ case M.foo_acf of M.foo_acf { DEFAULT -> blah }+ because the binder of a case-expression should never be imported. Rather,+ we must localise it thus:+ case M.foo_acf of foo_acf { DEFAULT -> blah }+ We keep the same unique, so in the next round of simplification we'll replace+ any M.foo_acf's in `blah` by `foo_acf`.++ c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils.+ Note [Specialising on dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In #21386, SpecConstr saw this call:@@ -2028,8 +2039,8 @@ | otherwise = return (extra_qvs, pat) --- See Note [SpecConstr and strict fields] mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr+-- See Note [SpecConstr and strict fields] mkSeqs seqees res_ty rhs = foldr addEval rhs seqees where@@ -2037,7 +2048,11 @@ addEval arg_id rhs -- Argument representing strict field and it's worth passing via cbv | shouldStrictifyIdForCbv arg_id- = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])+ = Case (Var arg_id)+ (localiseId arg_id) -- See (SCF1) in Note [SpecConstr and strict fields]+ res_ty+ ([Alt DEFAULT [] rhs])+ | otherwise = rhs
compiler/GHC/Core/Opt/Specialise.hs view
@@ -1485,11 +1485,12 @@ -- This is important: see Note [Update unfolding after specialisation] -- And in any case cloneBndrSM discards non-Stable unfoldings - fn3 = zapIdDemandInfo fn2+ fn3 = floatifyIdDemandInfo fn2 -- We zap the demand info because the binding may float, -- which would invalidate the demand info (see #17810 for example). -- Destroying demand info is not terrible; specialisation is -- always followed soon by demand analysis.+ -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds `extendInScope` fn3
compiler/GHC/CoreToStg/Prep.hs view
@@ -14,7 +14,6 @@ , CorePrepPgmConfig (..) , corePrepPgm , corePrepExpr- , mkConvertNumLiteral ) where @@ -24,11 +23,13 @@ import GHC.Driver.Flags -import GHC.Tc.Utils.Env import GHC.Unit import GHC.Builtin.Names+import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Types+import GHC.Builtin.Types.Prim import GHC.Core.Utils import GHC.Core.Opt.Arity@@ -60,14 +61,16 @@ import GHC.Types.Id.Info import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic-import GHC.Types.Name ( Name, NamedThing(..), nameSrcSpan, isInternalName )+import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import GHC.Types.Literal import GHC.Types.Tickish-import GHC.Types.TyThing import GHC.Types.Unique.Supply -import Data.List ( unfoldr )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import Data.ByteString.Builder.Prim+ import Control.Monad {-@@ -805,11 +808,10 @@ = return (emptyFloats, Type (cpSubstTy env ty)) cpeRhsE env (Coercion co) = return (emptyFloats, Coercion (cpSubstCo env co))-cpeRhsE env expr@(Lit (LitNumber nt i))- = case cp_convertNumLit (cpe_config env) nt i of- Nothing -> return (emptyFloats, expr)- Just e -> cpeRhsE env e-cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)+cpeRhsE env expr@(Lit lit)+ | LitNumber LitNumBigNat i <- lit+ = cpeBigNatLit env i+ | otherwise = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env expr@(App {}) = cpeApp env expr @@ -1548,7 +1550,7 @@ -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep] | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2- , not (has_join_in_tail_context arg)+ , not (eta_would_wreck_join arg) -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] = case exprEtaExpandArity ao arg of Nothing -> 0@@ -1557,15 +1559,15 @@ | otherwise = exprArity arg -- this is cheap enough for -O0 -has_join_in_tail_context :: CoreExpr -> Bool+eta_would_wreck_join :: CoreExpr -> Bool -- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in -- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]-has_join_in_tail_context (Let bs e) = isJoinBind bs || has_join_in_tail_context e-has_join_in_tail_context (Lam b e) | isTyVar b = has_join_in_tail_context e-has_join_in_tail_context (Cast e _) = has_join_in_tail_context e-has_join_in_tail_context (Tick _ e) = has_join_in_tail_context e-has_join_in_tail_context (Case _ _ _ alts) = any has_join_in_tail_context (rhssOfAlts alts)-has_join_in_tail_context _ = False+eta_would_wreck_join (Let bs e) = isJoinBind bs || eta_would_wreck_join e+eta_would_wreck_join (Lam _ e) = eta_would_wreck_join e+eta_would_wreck_join (Cast e _) = eta_would_wreck_join e+eta_would_wreck_join (Tick _ e) = eta_would_wreck_join e+eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts)+eta_would_wreck_join _ = False maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks@@ -1698,7 +1700,8 @@ (EA1) When eta expanding an argument headed by a join point, we might get "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts- it.+ it. This crap means the output does not conform to the syntax in+ Note [CorePrep invariants], which then makes later passes crash (#25033). Consider f (join j x = rhs in ...(j 1)...(j 2)...)@@ -1713,16 +1716,23 @@ In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App case of `coreToStgExpr`.- Hence we simply check for the cases where an intervening join point- binding in the tail context of the argument would lead to the introduction- of such crap via `has_join_in_tail_context`, in which case we abstain from- eta expansion. + Hence, in `eta_would_wreck_join`, we check for the cases where an+ intervening join point binding in the tail context of the argument would+ make eta-expansion break Note [CorePrep invariants], in which+ case we abstain from eta expansion.+ This scenario occurs rarely; hence it's OK to generate sub-optimal code. The alternative would be to fix Note [Eta expansion for join points], but that's quite challenging due to unfoldings of (recursive) join points. -(EA2) In cpeArgArity, if float_decision = FloatNone) the `arg` will look like+ `eta_would_wreck_join` sees if there are any join points, like `j` above+ that would be messed up. It must look inside lambdas (#25033); consider+ f (\x. join j y = ... in ...(j 1)...(j 3)...)+ We can't eta expand that `\x` any more than we could if the join was at+ the top. (And when there's a lambda, we don't have a thunk anyway.)++(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like let <binds> in rhs where <binds> is non-empty and can't be floated out of a lazy context (see `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0@@ -1894,6 +1904,16 @@ See also Note [Floats and FloatDecision] for how we maintain whole groups of floats and how far they go. +Note [Controlling Speculative Evaluation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Most of the time, speculative evaluation has a positive effect on performance,+but we have found a case where speculative evaluation of dictionary functions+leads to a performance regression #25284.++Therefore we have some flags to control it. See the optimization section in+the User's Guide for the description of these flags and when to use them.+ Note [Floats and FloatDecision] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have a special datatype `Floats` for modelling a telescope of `FloatingBind`@@ -2068,7 +2088,15 @@ is_lifted = not is_unlifted is_hnf = exprIsHNF rhs is_strict = isStrUsedDmd dmd- ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs+ cfg = cpe_config env++ ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs+ -- See Note [Controlling Speculative Evaluation]+ call_ok_for_spec x+ | is_rec_call x = False+ | not (cp_specEval cfg) = False+ | not (cp_specEvalDFun cfg) && isDFunId x = False+ | otherwise = True is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe @@ -2293,14 +2321,17 @@ -- cases. This is helpful when debugging demand analysis or type -- checker bugs which can sometimes manifest as segmentation faults. - , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr)- -- ^ Convert some numeric literals (Integer, Natural) into their final- -- Core form.+ , cp_platform :: Platform , cp_arityOpts :: !(Maybe ArityOpts) -- ^ Configuration for arity analysis ('exprEtaExpandArity'). -- See Note [Eta expansion of arguments in CorePrep] -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead+ , cp_specEval :: !Bool+ -- ^ Whether to perform speculative evaluation+ -- See Note [Controlling Speculative Evaluation]+ , cp_specEvalDFun :: !Bool+ -- ^ Whether to perform speculative evaluation on DFuns } data CorePrepEnv@@ -2532,57 +2563,119 @@ -- Numeric literals -- --------------------------------------------------------------------------- --- | Create a function that converts Bignum literals into their final CoreExpr-mkConvertNumLiteral- :: Platform- -> HomeUnit- -> (Name -> IO TyThing)- -> IO (LitNumType -> Integer -> Maybe CoreExpr)-mkConvertNumLiteral platform home_unit lookup_global = do- let- guardBignum act- | isHomeUnitInstanceOf home_unit primUnitId- = return $ panic "Bignum literals are not supported in ghc-prim"- | isHomeUnitInstanceOf home_unit bignumUnitId- = return $ panic "Bignum literals are not supported in ghc-bignum"- | otherwise = act+-- | Converts Bignum literals into their final CoreExpr+cpeBigNatLit+ :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)+cpeBigNatLit env i = assert (i >= 0) $ do+ let+ platform = cp_platform (cpe_config env) - lookupBignumId n = guardBignum (tyThingId <$> lookup_global n)+ -- Per the documentation in GHC.Num.BigNat, a BigNat# is:+ -- "Represented as an array of limbs (Word#) stored in+ -- little-endian order (Word# themselves use machine order)."+ --+ -- "Invariant (canonical representation): higher Word# is non-zero."+ -- So we need to break up the integer into target-word-sized chunks,+ -- and encode each of them using the target's byte-order.+ encodeBigNat+ :: forall a. Num a => FixedPrim a -> BS.ByteString+ encodeBigNat encodeWord+ = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i))+ -- (quadratic complexity due to repeated shifts... ok for now)+ where+ f 0 = Nothing+ f x = let low = fromInteger x :: a+ high = x `shiftR` bits+ in Just (low, high)+ bits = platformWordSizeInBits platform - -- The lookup is done here but the failure (panic) is reported lazily when we- -- try to access the `bigNatFromWordList` function.- --- -- If we ever get built-in ByteArray# literals, we could avoid the lookup by- -- directly using the Integer/Natural wired-in constructors for big numbers.+ words :: BS.ByteString+ words = case (platformWordSize platform, platformByteOrder platform) of+ (PW4, LittleEndian) -> encodeBigNat word32LE+ (PW4, BigEndian ) -> encodeBigNat word32BE+ (PW8, LittleEndian) -> encodeBigNat word64LE+ (PW8, BigEndian ) -> encodeBigNat word64BE - bignatFromWordListId <- lookupBignumId bignatFromWordListName+ -- Ideally we would just generate a ByteArray# literal here:+ -- pure (emptyFloats, Lit (LitByteArray words))+ -- But sadly we don't have those yet, even in Core. (See also #17747.)+ -- So instead we generate:+ -- * An `Addr#` literal that contains the contents of the+ -- `ByteArray#` we want to create. This gets its own float.+ -- * A call to `newByteArray#` with the appropriate size+ -- * A call to `copyAddrToByteArray#` to initialize the `ByteArray#`+ -- * A call to `unsafeFreezeByteArray#` to make the types match+ litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy+ -- returned from newByteArray#:+ deadNewByteArrayTupleId+ <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $+ mkTupleTy Unboxed [ realWorldStatePrimTy+ , realWorldMutableByteArrayPrimTy+ ]+ stateTokenFromNewByteArrayId+ <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+ mutableByteArrayId+ <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy+ -- returned from copyAddrToByteArray#:+ stateTokenFromCopyId+ <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+ -- returned from unsafeFreezeByteArray#:+ deadFreezeTupleId+ <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $+ mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]+ stateTokenFromFreezeId+ <- (`setIdOccInfo` IAmDead) <$>+ mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+ byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy - let- convertNumLit nt i = case nt of- LitNumBigNat -> Just (convertBignatPrim i)- _ -> Nothing+ let+ litAddrRhs = Lit (LitString words)+ -- not "mkLitString"; that does UTF-8 encoding, which we don't want here+ litAddrFloat = mkNonRecFloat env topDmd True litAddrId litAddrRhs - convertBignatPrim i =- let- -- ByteArray# literals aren't supported (yet). Were they supported,- -- we would use them directly. We would need to handle- -- wordSize/endianness conversion between host and target- -- wordSize = platformWordSize platform- -- byteOrder = platformByteOrder platform+ contentsLength = mkIntLit platform (toInteger (BS.length words)) - -- For now we build a list of Words and we produce- -- `bigNatFromWordList# list_of_words`+ newByteArrayCall =+ Var (primOpId NewByteArrayOp_Char)+ `App` Type realWorldTy+ `App` contentsLength+ `App` Var realWorldPrimId - words = mkListExpr wordTy (reverse (unfoldr f i))- where- f 0 = Nothing- f x = let low = x .&. mask- high = x `shiftR` bits- in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)- bits = platformWordSizeInBits platform- mask = 2 ^ bits - 1+ copyContentsCall =+ Var (primOpId CopyAddrToByteArrayOp)+ `App` Type realWorldTy+ `App` Var litAddrId+ `App` Var mutableByteArrayId+ `App` mkIntLit platform 0+ `App` contentsLength+ `App` Var stateTokenFromNewByteArrayId - in mkApps (Var bignatFromWordListId) [words]+ unsafeFreezeCall =+ Var (primOpId UnsafeFreezeByteArrayOp)+ `App` Type realWorldTy+ `App` Var mutableByteArrayId+ `App` Var stateTokenFromCopyId + unboxed2tuple_altcon :: AltCon+ unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2) - return convertNumLit+ finalRhs =+ Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy+ [ Alt unboxed2tuple_altcon+ [stateTokenFromNewByteArrayId, mutableByteArrayId]+ copyContentsCase+ ]++ copyContentsCase =+ Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy+ [ Alt DEFAULT [] unsafeFreezeCase+ ]++ unsafeFreezeCase =+ Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy+ [ Alt unboxed2tuple_altcon+ [stateTokenFromFreezeId, byteArrayId]+ (Var byteArrayId)+ ]++ pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs view
@@ -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.+-}
compiler/GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -10,7 +10,6 @@ import GHC.Driver.Session import GHC.Driver.Config.Core.Lint import GHC.Driver.Config.Core.Opt.Arity-import GHC.Tc.Utils.Env import GHC.Types.Var import GHC.Utils.Outputable ( alwaysQualify ) @@ -19,17 +18,14 @@ initCorePrepConfig :: HscEnv -> IO CorePrepConfig initCorePrepConfig hsc_env = do let dflags = hsc_dflags hsc_env- convertNumLit <- do- let platform = targetPlatform dflags- home_unit = hsc_home_unit hsc_env- lookup_global = lookupGlobal hsc_env- mkConvertNumLiteral platform home_unit lookup_global return $ CorePrepConfig { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags- , cp_convertNumLit = convertNumLit+ , cp_platform = targetPlatform dflags , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags then Just (initArityOpts dflags) else Nothing+ , cp_specEval = gopt Opt_SpecEval dflags+ , cp_specEvalDFun = gopt Opt_SpecEvalDictFun dflags } initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -14,6 +14,7 @@ import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile+import GHC.Platform.Regs import GHC.Utils.Error import GHC.Unit.Module import GHC.Utils.Outputable@@ -76,13 +77,16 @@ | otherwise -> const True - , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm+ , stgToCmmAllowIntMul2Instr = (ncg && (x86ish || aarch64)) || llvm+ , stgToCmmAllowWordMul2Instr = (ncg && (x86ish || ppc || aarch64)) || llvm -- SIMD flags , stgToCmmVecInstrsErr = vec_err , stgToCmmAvx = isAvxEnabled dflags , stgToCmmAvx2 = isAvx2Enabled dflags , stgToCmmAvx512f = isAvx512fEnabled dflags , stgToCmmTickyAP = gopt Opt_Ticky_AP dflags+ -- See Note [Saving foreign call target to local]+ , stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform } where profile = targetProfile dflags platform = profilePlatform profile bk_end = backend dflags@@ -92,6 +96,9 @@ JSPrimitives -> (False, False) NcgPrimitives -> (True, False) LlvmPrimitives -> (False, True)+ aarch64 = case platformArch platform of+ ArchAArch64 -> True+ _ -> False x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True
compiler/GHC/Driver/Main.hs view
@@ -6,9 +6,6 @@ {-# OPTIONS_GHC -fprof-auto-top #-} --- Remove this after cmmToRawCmmHook removal-{-# OPTIONS_GHC -Wno-deprecations #-}- ------------------------------------------------------------------------------- -- -- | Main API for compiling plain Haskell source code.@@ -1805,7 +1802,7 @@ if gopt Opt_ProfLateInlineCcs dflags then LateCCNone else if gopt Opt_ProfLateCcs dflags then- LateCCAllBinds+ LateCCBinds else if gopt Opt_ProfLateOverloadedCcs dflags then LateCCOverloadedBinds else@@ -2665,7 +2662,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
compiler/GHC/Driver/Make.hs view
@@ -299,16 +299,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@@ -319,8 +319,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.@@ -329,27 +327,31 @@ -- `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 =+ is_module_target 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_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_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+ is_file_target file = Set.member (withoutExt file) file_targets++ 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 = Set.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) $
compiler/GHC/Driver/Pipeline.hs view
@@ -542,28 +542,28 @@ compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) compileFile hsc_env stop_phase (src, mb_phase) = do- exists <- doesFileExist src- when (not exists) $- throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))+ let offset_file = augmentByWorkingDirectory dflags src+ dflags = hsc_dflags hsc_env+ mb_o_file = outputFile dflags+ ghc_link = ghcLink dflags -- Set by -c or -no-link+ notStopPreprocess | StopPreprocess <- stop_phase = False+ | _ <- stop_phase = True+ -- When linking, the -o argument refers to the linker's output.+ -- otherwise, we use it as the name for the pipeline's output.+ output+ | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile+ -- avoid -E -fno-code undesirable interactions. see #20439+ | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent+ -- -o foo applies to linker+ | isJust mb_o_file = SpecificFile+ -- -o foo applies to the file we are compiling now+ | otherwise = Persistent+ pipe_env = mkPipeEnv stop_phase offset_file mb_phase output+ pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase - let- dflags = hsc_dflags hsc_env- mb_o_file = outputFile dflags- ghc_link = ghcLink dflags -- Set by -c or -no-link- notStopPreprocess | StopPreprocess <- stop_phase = False- | _ <- stop_phase = True- -- When linking, the -o argument refers to the linker's output.- -- otherwise, we use it as the name for the pipeline's output.- output- | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile- -- avoid -E -fno-code undesirable interactions. see #20439- | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent- -- -o foo applies to linker- | isJust mb_o_file = SpecificFile- -- -o foo applies to the file we are compiling now- | otherwise = Persistent- pipe_env = mkPipeEnv stop_phase src mb_phase output- pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase+ exists <- doesFileExist offset_file+ when (not exists) $+ throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file)) runPipeline (hsc_hooks hsc_env) pipeline
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -121,8 +121,8 @@ (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (CppOpts- { useHsCpp = False- , cppLinePragmas = True+ { sourceCodePreprocessor = SCPCmmCpp+ , cppLinePragmas = True }) input_fn output_fn return output_fn@@ -652,8 +652,8 @@ (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (CppOpts- { useHsCpp = True- , cppLinePragmas = True+ { sourceCodePreprocessor = SCPHsCpp+ , cppLinePragmas = True }) input_fn output_fn return output_fn@@ -964,7 +964,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 ]
compiler/GHC/Iface/Env.hs view
@@ -270,9 +270,9 @@ | (occ,uniq) <- occs `zip` uniqs] } trace_if :: Logger -> SDoc -> IO ()-{-# INLINE trace_if #-}+{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities] trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc trace_hi_diffs :: Logger -> SDoc -> IO ()-{-# INLINE trace_hi_diffs #-}+{-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities] trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc
compiler/GHC/Iface/Load.hs view
@@ -443,9 +443,6 @@ ; case lookupIfaceByModule hug (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded- -- The (src_imp == mi_boot iface) test checks that the already-loaded- -- interface isn't a boot iface. This can conceivably happen,- -- if an earlier import had a before we got to real imports. I think. _ -> do { -- READ THE MODULE IN
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -50,13 +50,26 @@ -- see Note [Implicit include paths] includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] } - -- -I, -D and -U flags affect CPP+ -- -I, -D and -U flags affect Haskell C/CPP Preprocessor cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit -- normalise: eliminate spurious differences due to "./foo" vs "foo" , picPOpts dflags , opt_P_signature dflags) -- See Note [Repeated -optP hashing] + -- -I, -D and -U flags affect JavaScript C/CPP Preprocessor+ js = ( map normalise $ flattenIncludes includePathsMinusImplicit+ -- normalise: eliminate spurious differences due to "./foo" vs "foo"+ , picPOpts dflags+ , opt_JSP_signature dflags)+ -- See Note [Repeated -optP hashing]++ -- -I, -D and -U flags affect C-- CPP Preprocessor+ cmm = ( map normalise $ flattenIncludes includePathsMinusImplicit+ -- normalise: eliminate spurious differences due to "./foo" vs "foo"+ , picPOpts dflags+ , opt_CmmP_signature dflags)+ -- Note [path flags and recompilation] paths = [ hcSuf ] @@ -70,7 +83,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, js, cmm), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags
compiler/GHC/Iface/Tidy.hs view
@@ -645,8 +645,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
compiler/GHC/Linker/Loader.hs view
@@ -55,6 +55,7 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Iface.Load+import GHCi.Message (LoadedDLL) import GHC.ByteCode.Linker import GHC.ByteCode.Asm@@ -172,7 +173,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 =@@ -221,8 +222,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@@ -512,25 +513,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 ->@@ -614,7 +615,7 @@ -- Load the necessary packages and linkables let le = linker_env pls bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]- resolved <- linkBCO interp le bco_ix root_ul_bco+ resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix root_ul_bco [root_hvref] <- createBCOs interp [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv)@@ -677,7 +678,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 } }@@ -858,8 +859,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" @@ -899,7 +900,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@@ -914,6 +915,7 @@ -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp+ -> PkgsLoaded -> LinkerEnv -> [CompiledByteCode] -> IO [(Name,HValueRef)]@@ -921,7 +923,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 = inner (bc_bcos : accum) @@ -930,7 +932,7 @@ let flat = [ bco | bcos <- mods, bco <- bcos ] names = map unlinkedBCOName flat bco_ix = mkNameEnv (zip names [0..])- resolved <- sequence [ linkBCO interp le bco_ix bco | bco <- flat ]+ resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -1092,18 +1094,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@@ -1145,7 +1147,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@@ -1166,10 +1170,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@@ -1189,7 +1196,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))@@ -1242,19 +1249,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
compiler/GHC/Linker/MacOS.hs view
@@ -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) }
compiler/GHC/Rename/Env.hs view
@@ -1031,8 +1031,32 @@ -- lookupOccRnConstr looks up an occurrence of a RdrName and displays -- constructors and pattern synonyms as suggestions if it is not in scope+--+-- There is a fallback to the type level, when the first lookup fails.+-- This is required to implement a pat-to-type transformation+-- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)+-- Consider this example:+--+-- data VisProxy a where VP :: forall a -> VisProxy a+--+-- f :: VisProxy Int -> ()+-- f (VP Int) = ()+--+-- Here `Int` is actually a type, but it stays on position where+-- we expect a data constructor.+--+-- In all other cases we just use this additional lookup for better+-- error messaging (See Note [Promotion]). lookupOccRnConstr :: RdrName -> RnM Name-lookupOccRnConstr = lookupOccRn' WL_Constructor+lookupOccRnConstr rdr_name+ = do { mb_gre <- lookupOccRn_maybe rdr_name+ ; case mb_gre of+ Just gre -> return $ greName gre+ Nothing -> do+ { mb_ty_gre <- lookup_promoted rdr_name+ ; case mb_ty_gre of+ Just gre -> return $ greName gre+ Nothing -> reportUnboundName' WL_Constructor rdr_name} } -- lookupOccRnRecField looks up an occurrence of a RdrName and displays -- record fields as suggestions if it is not in scope
compiler/GHC/Rename/Module.hs view
@@ -1972,6 +1972,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.
compiler/GHC/Rename/Pat.hs view
@@ -71,7 +71,6 @@ import GHC.Utils.Misc import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups )-import GHC.Data.Bag ( Bag, unitBag, unionBags, emptyBag, listToBag, bagToList ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc@@ -89,7 +88,6 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio-import qualified Data.Semigroup as S import Control.Monad.Trans.Writer.CPS import Control.Monad.Trans.Class import Control.Monad.Trans.Reader@@ -1242,43 +1240,6 @@ name <- lookupTypeOccRn rdr_name pure (name, unitFV name) --- | A variant of HsTyPatRn that uses Bags for efficient concatenation.--- See Note [Implicit and explicit type variable binders]-data HsTyPatRnBuilder =- HsTPRnB {- hstpb_nwcs :: Bag Name,- hstpb_imp_tvs :: Bag Name,- hstpb_exp_tvs :: Bag Name- }--tpb_exp_tv :: Name -> HsTyPatRnBuilder-tpb_exp_tv name = mempty {hstpb_exp_tvs = unitBag name}--tpb_hsps :: HsPSRn -> HsTyPatRnBuilder-tpb_hsps HsPSRn {hsps_nwcs, hsps_imp_tvs} =- mempty {- hstpb_nwcs = listToBag hsps_nwcs,- hstpb_imp_tvs = listToBag hsps_imp_tvs- }--instance Semigroup HsTyPatRnBuilder where- HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 =- HsTPRnB- (nwcs1 `unionBags` nwcs2)- (imp_tvs1 `unionBags` imp_tvs2)- (exptvs1 `unionBags` exptvs2)--instance Monoid HsTyPatRnBuilder where- mempty = HsTPRnB emptyBag emptyBag emptyBag--buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn-buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} =- HsTPRn {- hstp_nwcs = bagToList hstpb_nwcs,- hstp_imp_tvs = bagToList hstpb_imp_tvs,- hstp_exp_tvs = bagToList hstpb_exp_tvs- }- rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) rn_lty_pat (L l hs_ty) = do hs_ty' <- rn_ty_pat hs_ty@@ -1292,7 +1253,7 @@ then do -- binder name <- liftTPRnCps $ newPatName (LamMk True) lrdr- tellTPB (tpb_exp_tv name)+ tellTPB (tpBuilderExplicitTV name) pure (L l name) else do -- usage@@ -1413,7 +1374,7 @@ ~(HsPS hsps ki') <- liftRnWithCont $ rnHsPatSigKind AlwaysBind ctxt (HsPS noAnn ki) ty' <- rn_lty_pat ty- tellTPB (tpb_hsps hsps)+ tellTPB (tpBuilderPatSig hsps) pure (HsKindSig an ty' ki') rn_ty_pat (HsSpliceTy _ splice) = do
compiler/GHC/Runtime/Eval.hs view
@@ -107,7 +107,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing-import GHC.Types.BreakInfo+import GHC.Types.Breakpoint import GHC.Types.Unique.Map import GHC.Unit@@ -143,29 +143,27 @@ getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History-mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)+mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> History+mkHistory hsc_env hval ibi = History hval ibi (findEnclosingDecls hsc_env ibi) getHistoryModule :: History -> Module-getHistoryModule = breakInfo_module . historyBreakInfo+getHistoryModule = ibi_tick_mod . historyBreakpointId getHistorySpan :: HscEnv -> History -> SrcSpan-getHistorySpan hsc_env History{..} =- let BreakInfo{..} = historyBreakInfo in- case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of- Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number+getHistorySpan hsc_env hist =+ let ibi = historyBreakpointId hist in+ case lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env) of+ Just hmi -> modBreaks_locs (getModBreaks hmi) ! ibi_tick_index ibi _ -> panic "getHistorySpan" {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick.-findEnclosingDecls :: HscEnv -> BreakInfo -> [String]-findEnclosingDecls hsc_env (BreakInfo modl ix) =- let hmi = expectJust "findEnclosingDecls" $- lookupHugByModule modl (hsc_HUG hsc_env)- mb = getModBreaks hmi- in modBreaks_decls mb ! ix+findEnclosingDecls :: HscEnv -> InternalBreakpointId -> [String]+findEnclosingDecls hsc_env ibi =+ let hmi = expectJust "findEnclosingDecls" $ lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env)+ in modBreaks_decls (getModBreaks hmi) ! ibi_tick_index ibi -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m ()@@ -324,27 +322,24 @@ | otherwise = not_tracing where tracing- | EvalBreak apStack_ref maybe_break resume_ctxt _ccs <- status- , Just (EvalBreakpoint ix mod_name) <- maybe_break+ | EvalBreak apStack_ref (Just eval_break) resume_ctxt _ccs <- status = do hsc_env <- getSession let interp = hscInterp hsc_env let dflags = hsc_dflags hsc_env- let hmi = expectJust "handleRunStatus" $- lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name)- modl = mi_module (hm_iface hmi)+ let ibi = evalBreakpointToId (hsc_HPT hsc_env) eval_break+ let hmi = expectJust "handleRunStatus" $ lookupHpt (hsc_HPT hsc_env) (moduleName (ibi_tick_mod ibi)) breaks = getModBreaks hmi b <- liftIO $- breakpointStatus interp (modBreaks_flags breaks) ix+ breakpointStatus interp (modBreaks_flags breaks) (ibi_tick_index ibi) if b then not_tracing -- This breakpoint is explicitly enabled; we want to stop -- instead of just logging it. else do apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref- let bi = BreakInfo modl ix- !history' = mkHistory hsc_env apStack_fhv bi `consBL` history+ let !history' = mkHistory hsc_env apStack_fhv ibi `consBL` history -- history is strict, otherwise our BoundedList is pointless. fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt let eval_opts = initEvalOpts dflags True@@ -362,23 +357,27 @@ let interp = hscInterp hsc_env resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref- let bp = evalBreakInfo (hsc_HPT hsc_env) <$> maybe_break+ let ibi = evalBreakpointToId (hsc_HPT hsc_env) <$> maybe_break (hsc_env1, names, span, decl) <- liftIO $- bindLocalsAtBreakpoint hsc_env apStack_fhv bp+ bindLocalsAtBreakpoint hsc_env apStack_fhv ibi let resume = Resume- { resumeStmt = expr, resumeContext = resume_ctxt_fhv- , resumeBindings = bindings, resumeFinalIds = final_ids+ { resumeStmt = expr+ , resumeContext = resume_ctxt_fhv+ , resumeBindings = bindings+ , resumeFinalIds = final_ids , resumeApStack = apStack_fhv- , resumeBreakInfo = bp- , resumeSpan = span, resumeHistory = toListBL history+ , resumeBreakpointId = ibi+ , resumeSpan = span+ , resumeHistory = toListBL history , resumeDecl = decl , resumeCCS = ccs- , resumeHistoryIx = 0 }+ , resumeHistoryIx = 0+ } hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2- return (ExecBreak names bp)+ return (ExecBreak names ibi) -- Completed successfully | EvalComplete allocs (EvalSuccess hvals) <- status@@ -428,16 +427,21 @@ liftIO $ Loader.deleteFromLoadedEnv interp new_names case r of- Resume { resumeStmt = expr, resumeContext = fhv- , resumeBindings = bindings, resumeFinalIds = final_ids- , resumeApStack = apStack, resumeBreakInfo = mb_brkpt+ Resume { resumeStmt = expr+ , resumeContext = fhv+ , resumeBindings = bindings+ , resumeFinalIds = final_ids+ , resumeApStack = apStack+ , resumeBreakpointId = mb_brkpt , resumeSpan = span , resumeHistory = hist } -> withVirtualCWD $ do- when (isJust mb_brkpt && isJust mbCnt) $ do- setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)- -- When the user specified a break ignore count, set it- -- in the interpreter+ -- When the user specified a break ignore count, set it+ -- in the interpreter+ case (mb_brkpt, mbCnt) of+ (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt+ _ -> return ()+ let eval_opts = initEvalOpts dflags (isStep step) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist@@ -449,16 +453,15 @@ fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m () -- #19157-setupBreakpoint hsc_env brkInfo cnt = do- let modl :: Module = breakInfo_module brkInfo+setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157+setupBreakpoint hsc_env bi cnt = do+ let modl = bi_tick_mod bi breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName modl)- ix = breakInfo_number brkInfo modBreaks = breaks hsc_env modl breakarray = modBreaks_flags modBreaks interp = hscInterp hsc_env- _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt+ _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt pure () back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)@@ -501,11 +504,11 @@ if new_ix == 0 then case r of Resume { resumeApStack = apStack,- resumeBreakInfo = mb_brkpt } ->+ resumeBreakpointId = mb_brkpt } -> update_ic apStack mb_brkpt else case history !! (new_ix - 1) of History{..} ->- update_ic historyApStack (Just historyBreakInfo)+ update_ic historyApStack (Just historyBreakpointId) -- -----------------------------------------------------------------------------@@ -517,7 +520,7 @@ bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue- -> Maybe BreakInfo+ -> Maybe InternalBreakpointId -> IO (HscEnv, [Name], SrcSpan, String) -- Nothing case: we stopped when an exception was raised, not at a@@ -543,25 +546,28 @@ -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression.-bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do let- hmi = expectJust "bindLocalsAtBreakpoint" $- lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) interp = hscInterp hsc_env- breaks = getModBreaks hmi- info = expectJust "bindLocalsAtBreakpoint2" $- IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)- occs = modBreaks_vars breaks ! breakInfo_number- span = modBreaks_locs breaks ! breakInfo_number- decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number + info_mod = ibi_info_mod ibi+ info_hmi = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName info_mod)+ info_brks = getModBreaks info_hmi+ info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)++ tick_mod = ibi_tick_mod ibi+ tick_hmi = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod)+ tick_brks = getModBreaks tick_hmi+ occs = modBreaks_vars tick_brks ! ibi_tick_index ibi+ span = modBreaks_locs tick_brks ! ibi_tick_index ibi+ decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi+ -- Rehydrate to understand the breakpoint info relative to the current environment. -- This design is critical to preventing leaks (#22530) (mbVars, result_ty) <- initIfaceLoad hsc_env- $ initIfaceLcl breakInfo_module (text "debugger") NotBoot+ $ initIfaceLcl info_mod (text "debugger") NotBoot $ hydrateCgBreakInfo info - let -- Filter out any unboxed ids by changing them to Nothings;@@ -614,8 +620,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
compiler/GHC/Runtime/Interpreter.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} -- | Interacting with the iserv interpreter, whether it is running on an@@ -28,13 +27,14 @@ , getClosure , getModBreaks , seqHValue- , evalBreakInfo+ , evalBreakpointToId , interpreterDynamic , interpreterProfiled -- * The object-code linker , initObjLinker , lookupSymbol+ , lookupSymbolInDLL , lookupClosure , loadDLL , loadArchive@@ -73,7 +73,7 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray)-import GHC.Types.BreakInfo (BreakInfo(..))+import GHC.Types.Breakpoint import GHC.ByteCode.Types import GHC.Linker.Types@@ -151,22 +151,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@@ -394,14 +394,15 @@ status <- interpCmd interp (Seq hval) handleSeqHValueStatus interp unit_env status -evalBreakInfo :: HomePackageTable -> EvalBreakpoint -> BreakInfo-evalBreakInfo hpt (EvalBreakpoint ix mod_name) =- BreakInfo modl ix- where- modl = mi_module $- hm_iface $- expectJust "evalBreakInfo" $- lookupHpt hpt (mkModuleName mod_name)+evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> InternalBreakpointId+evalBreakpointToId hpt eval_break =+ let load_mod x = mi_module $ hm_iface $ expectJust "evalBreakpointToId" $ lookupHpt hpt (mkModuleName x)+ in InternalBreakpointId+ { ibi_tick_mod = load_mod (eb_tick_mod eval_break)+ , ibi_tick_index = eb_tick_index eval_break+ , ibi_info_mod = load_mod (eb_info_mod eval_break)+ , ibi_info_index = eb_info_index eval_break+ } -- | Process the result of a Seq or ResumeSeq message. #2950 handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())@@ -411,7 +412,7 @@ -- A breakpoint was hit; inform the user and tell them -- which breakpoint was hit. resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt- let bp = evalBreakInfo (ue_hpt unit_env) <$> maybe_break+ let bp = evalBreakpointToId (ue_hpt unit_env) <$> maybe_break sdocBpLoc = brackets . ppr . getSeqBpSpan putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe $ sdocBpLoc bp))@@ -421,14 +422,15 @@ handleSeqHValueStatus interp unit_env status (EvalComplete _ r) -> return r where- getSeqBpSpan :: Maybe BreakInfo -> SrcSpan- -- Just case: Stopped at a breakpoint, extract SrcSpan information- -- from the breakpoint.- getSeqBpSpan (Just BreakInfo{..}) =- (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number- -- Nothing case - should not occur!- -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq- getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")+ getSeqBpSpan :: Maybe InternalBreakpointId -> SrcSpan+ getSeqBpSpan = \case+ Just bi -> (modBreaks_locs (breaks (ibi_tick_mod bi))) ! ibi_tick_index bi+ -- Just case: Stopped at a breakpoint, extract SrcSpan information+ -- from the breakpoint.+ Nothing -> mkGeneralSrcSpan (fsLit "<unknown>")+ -- Nothing case - should not occur!+ -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq+ -- breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $ lookupHpt (ue_hpt unit_env) (moduleName mod) @@ -440,57 +442,78 @@ initObjLinker interp = interpCmd interp InitLinker lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))-lookupSymbol interp str = case interpInstance interp of+lookupSymbol interp str = withSymbolCache interp str $+ case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #endif-- ExternalInterp ext -> case ext of- ExtIServ i -> withIServ i $ \inst -> 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.- cache <- readMVar (instLookupSymbolCache inst)- case lookupUFM cache str of- Just p -> return (Just p)- Nothing -> do- m <- uninterruptibleMask_ $- sendMessage inst (LookupSymbol (unpackFS str))- case m of- Nothing -> return Nothing- Just r -> do- let p = fromRemotePtr r- cache' = addToUFM cache str p- modifyMVar_ (instLookupSymbolCache inst) (const (pure cache'))- return (Just p)+ ExternalInterp ext -> case ext of+ ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do+ uninterruptibleMask_ $+ sendMessage inst (LookupSymbol (unpackFS str))+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) - 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 ()@@ -549,11 +572,9 @@ } pending_frees <- newMVar []- lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = process , instPendingFrees = pending_frees- , instLookupSymbolCache = lookup_cache , instExtra = () } pure inst
compiler/GHC/Runtime/Interpreter/JS.hs view
@@ -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 }
compiler/GHC/Settings/IO.hs view
@@ -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,29 +74,40 @@ -- 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" cc_args_str <- getToolSetting "C compiler flags" cxx_args_str <- getToolSetting "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" hs_cpp_prog <- getToolSetting "Haskell CPP command" hs_cpp_args_str <- getToolSetting "Haskell CPP flags"+ js_cpp_prog <- getToolSetting "JavaScript CPP command"+ js_cpp_args_str <- getToolSetting "JavaScript CPP flags"+ cmmCpp_prog <- getToolSetting "C-- CPP command"+ cmmCpp_args_str <- getToolSetting "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 (words cpp_args_str)- hs_cpp_args = map Option (words hs_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)+ 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 -- The extra flags we need to pass gcc when we invoke it to compile .hc code. --@@ -135,12 +148,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" @@ -177,9 +190,12 @@ , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW , toolSettings_arSupportsDashL = arSupportsDashL+ , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 , toolSettings_pgm_L = unlit_path , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args)+ , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args)+ , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args) , toolSettings_pgm_F = "" , toolSettings_pgm_c = cc_prog , toolSettings_pgm_cxx = cxx_prog@@ -198,7 +214,11 @@ , toolSettings_pgm_i = iserv_prog , toolSettings_opt_L = [] , toolSettings_opt_P = []- , toolSettings_opt_P_fingerprint = fingerprint0+ , toolSettings_opt_JSP = []+ , toolSettings_opt_CmmP = []+ , toolSettings_opt_P_fingerprint = fingerprint0+ , toolSettings_opt_JSP_fingerprint = fingerprint0+ , toolSettings_opt_CmmP_fingerprint = fingerprint0 , toolSettings_opt_F = [] , toolSettings_opt_c = cc_args , toolSettings_opt_cxx = cxx_args@@ -261,3 +281,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
compiler/GHC/StgToByteCode.hs view
@@ -383,27 +383,40 @@ -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs mod) rhs) = do+schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do code <- schemeE d 0 p rhs hsc_env <- getHscEnv current_mod <- getCurrentModule- current_mod_breaks <- getCurrentModBreaks- case break_info hsc_env mod current_mod current_mod_breaks of+ mb_current_mod_breaks <- getCurrentModBreaks+ case mb_current_mod_breaks of+ -- if we're not generating ModBreaks for this module for some reason, we+ -- can't store breakpoint occurrence information. Nothing -> pure code- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = mod_ptr, modBreaks_ccs = cc_arr} -> do- platform <- profilePlatform <$> getProfile- let idOffSets = getVarOffSets platform d p fvs- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty- newBreakInfo tick_no breakInfo- let cc | Just interp <- hsc_interp hsc_env- , interpreterProfiled interp- = cc_arr ! tick_no- | otherwise = toRemotePtr nullPtr- breakInstr = BRK_FUN breaks (fromIntegral tick_no) mod_ptr cc- return $ breakInstr `consOL` code+ Just current_mod_breaks -> case break_info hsc_env tick_mod current_mod mb_current_mod_breaks of+ Nothing -> pure code+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do+ platform <- profilePlatform <$> getProfile+ let idOffSets = getVarOffSets platform d p fvs+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty++ let info_mod_ptr = modBreaks_module current_mod_breaks+ infox <- newBreakInfo breakInfo++ let cc | Just interp <- hsc_interp hsc_env+ , interpreterProfiled interp+ = cc_arr ! tick_no+ | otherwise = toRemotePtr nullPtr++ let -- cast that checks that round-tripping through Word16 doesn't change the value+ toW16 x = let r = fromIntegral x :: Word16+ in if fromIntegral r == x+ then r+ else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)+ breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc+ return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs -- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module@@ -515,7 +528,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@@ -783,7 +796,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@@ -1405,7 +1418,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.@@ -2150,8 +2163,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@@ -2188,7 +2201,12 @@ , ffis :: [FFIInfo] -- ffi info blocks, to free later -- Should be free()d when it is GCd , modBreaks :: Maybe ModBreaks -- info about breakpoints- , breakInfo :: IntMap CgBreakInfo++ , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.+ -- Indexed with breakpoint *info* index.+ -- See Note [Breakpoint identifiers]+ -- in GHC.Types.Breakpoint+ , breakInfoIdx :: !Int -- ^ Next index for breakInfo array } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)@@ -2202,7 +2220,7 @@ -> BcM r -> IO (BcM_State, r) runBc hsc_env this_mod modBreaks (BcM m)- = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty)+ = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty 0) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do@@ -2258,9 +2276,14 @@ = BcM $ \st -> let ctr = nextlabel st in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) -newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()-newBreakInfo ix info = BcM $ \st ->- return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())+newBreakInfo :: CgBreakInfo -> BcM Int+newBreakInfo info = BcM $ \st ->+ let ix = breakInfoIdx st+ st' = st+ { breakInfo = IntMap.insert ix info (breakInfo st)+ , breakInfoIdx = ix + 1+ }+ in return (st', ix) getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st)
compiler/GHC/StgToCmm/Foreign.hs view
@@ -277,23 +277,83 @@ load_target_into_temp other_target@(PrimTarget _) = return other_target +-- Note [Saving foreign call target to local]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- -- What we want to do here is create a new temporary for the foreign -- call argument if it is not safe to use the expression directly, -- because the expression mentions caller-saves GlobalRegs (see -- Note [Register parameter passing]). -- -- However, we can't pattern-match on the expression here, because--- this is used in a loop by GHC.Cmm.Parser, and testing the expression--- results in a black hole. So we always create a temporary, and rely--- on GHC.Cmm.Sink to clean it up later. (Yuck, ToDo). The generated code--- ends up being the same, at least for the RTS .cmm code.+-- this is used in a loop by GHC.Cmm.Parser, and testing the+-- expression results in a black hole. So when there exist+-- caller-saves GlobalRegs, we create a temporary, and rely on+-- GHC.Cmm.Sink to clean it up later. The generated code ends up being+-- the same if -fcmm-sink is enabled (implied by -O). --+-- When there doesn't exist caller-save GlobalRegs, keep the original+-- target in place. This matters for the wasm backend, otherwise it+-- cannot infer the target symbol's correct foreign function type in+-- unoptimized Cmm. For instance:+--+-- foreign import ccall unsafe "foo" c_foo :: IO ()+--+-- Without optimization, previously this would lower to something like:+--+-- [Test.c_foo_entry() { // []+-- { []+-- }+-- {offset+-- cDk:+-- goto cDm;+-- cDm:+-- _cDj::I32 = foo;+-- call "ccall" arg hints: [] result hints: [] (_cDj::I32)();+-- R1 = GHC.Tuple.()_closure+1;+-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4;+-- }+-- },+--+-- The wasm backend only sees "foo" being assigned to a local, but+-- there's no type signature associated with a CLabel! So it has to+-- emit a dummy .functype directive and fingers crossed that wasm-ld+-- tolerates function type mismatch. THis is horrible, not future+-- proof against upstream toolchain upgrades, and already known to+-- break in certain cases (e.g. when LTO objects are involved).+--+-- Therefore, on wasm as well as other targets that don't risk+-- mentioning caller-saved GlobalRegs in a foreign call target, just+-- keep the original call target in place and don't assign it to a+-- local. So this would now lower to something like:+--+-- [Test.c_foo_entry() { // []+-- { []+-- }+-- {offset+-- cDo:+-- goto cDq;+-- cDq:+-- call "ccall" arg hints: [] result hints: [] foo();+-- R1 = GHC.Tuple.()_closure+1;+-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4;+-- }+-- },+--+-- Since "foo" appears at call site directly, the wasm backend would+-- now be able to infer its type signature correctly.+ maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e = do- platform <- getPlatform- reg <- newTemp (cmmExprType platform e)- emitAssign (CmmLocal reg) e- return (CmmReg (CmmLocal reg))+ do_save <- stgToCmmSaveFCallTargetToLocal <$> getStgToCmmConfig+ if do_save+ then do+ platform <- getPlatform+ reg <- newTemp (cmmExprType platform e)+ emitAssign (CmmLocal reg) e+ return (CmmReg (CmmLocal reg))+ else+ pure e -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO
compiler/GHC/StgToCmm/InfoTableProv.hs view
@@ -178,7 +178,7 @@ to_ipe_buf_ent :: CgInfoProvEnt -> [Word32] to_ipe_buf_ent cg_ipe = [ ipeTableName cg_ipe- , ipeClosureDesc cg_ipe+ , fromIntegral $ ipeClosureDesc cg_ipe , ipeTypeDesc cg_ipe , ipeLabel cg_ipe , ipeSrcFile cg_ipe@@ -193,7 +193,6 @@ toCgIPE :: Platform -> SDocContext -> InfoProvEnt -> State StringTable CgInfoProvEnt toCgIPE platform ctx ipe = do table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))- closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe) type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe) let (src_loc_file, src_loc_span) =@@ -208,7 +207,7 @@ src_span <- lookupStringTable $ ST.pack src_loc_span return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe , ipeTableName = table_name- , ipeClosureDesc = closure_desc+ , ipeClosureDesc = fromIntegral (infoProvEntClosureType ipe) , ipeTypeDesc = type_desc , ipeLabel = label , ipeSrcFile = src_file@@ -218,7 +217,7 @@ data CgInfoProvEnt = CgInfoProvEnt { ipeInfoTablePtr :: !CLabel , ipeTableName :: !StrTabOffset- , ipeClosureDesc :: !StrTabOffset+ , ipeClosureDesc :: !Word32 , ipeTypeDesc :: !StrTabOffset , ipeLabel :: !StrTabOffset , ipeSrcFile :: !StrTabOffset
compiler/GHC/StgToCmm/Prim.hs view
@@ -1623,7 +1623,7 @@ else Right genericIntSubCOp WordMul2Op -> \args -> opCallishHandledLater args $- if allowExtAdd+ if allowWord2Mul then Left (MO_U_Mul2 (wordWidth platform)) else Right genericWordMul2Op @@ -1850,6 +1850,7 @@ allowQuotRem2 = stgToCmmAllowQuotRem2 cfg allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg allowInt2Mul = stgToCmmAllowIntMul2Instr cfg+ allowWord2Mul = stgToCmmAllowWordMul2Instr cfg allowFMA = stgToCmmAllowFMAInstr cfg @@ -2180,8 +2181,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
compiler/GHC/StgToJS/Linker/Linker.hs view
@@ -284,10 +284,31 @@ hPutChar h '\n' let emcc_opts' = emcc_opts <> opts go_entries emcc_opts' cc_objs es- Nothing -> do- logInfo logger (vcat [text "Ignoring unexpected archive entry: ", text (Ar.filename e)])- go_entries emcc_opts cc_objs es+ Nothing -> case Ar.filename e of+ -- JavaScript code linker does not support symbol table processing.+ -- Currently the linker does nothing when the symbol table is met.+ -- Ar/Ranlib usually do not create a record for the symbol table+ -- in the object archive when the table has no entries.+ -- For JavaScript code it should not be created by default. + "__.SYMDEF" ->+ -- GNU Ar added the symbol table.++ -- Emscripten Ar (at least 3.1.24 version)+ -- adds it even when the symbol table is empty.+ go_entries emcc_opts cc_objs es+ "__.SYMDEF SORTED" ->+ -- BSD-like Ar added the symbol table.++ -- By default, Clang Ar does not add it when the+ -- symbol table is empty (and it should be empty) but we left+ -- it here to handle the case with symbol table completely+ -- for GNU and BSD tools.+ go_entries emcc_opts cc_objs es+ unknown_name -> do+ logInfo logger (vcat [text "Ignoring unexpected archive entry: ", text unknown_name])+ go_entries emcc_opts cc_objs es+ -- additional JS objects (e.g. from the command-line) go_extra emcc_opts = \case [] -> pure emcc_opts@@ -728,12 +749,64 @@ rtsExterns :: FastString rtsExterns =+ -- Google Closure Compiler --externs option is deprecated.+ -- Need pass them as a js file with @externs module-level jsdoc.+ "/** @externs @suppress {duplicate} */\n" <> "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <>- mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n")- [(7::Int)..16384])+ mconcat+ -- See GHC.StgToJS+ -- We connect all payload fields "dXX" on JavaScript Object.+ -- That's most simple way to make Google Closure Compiler prevent+ -- property names mangling.+ (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n")+ [(1::Int)..16384]) <>+ mconcat+ (map (\x -> "/** @type {*} */\nObject." <> x <> ";\n")+ -- We do same for special STG properties as well.+ ["m", "f", "cc", "t", "size", "i", "n", "a", "r", "s"]) <>+ mconcat+ [ -- Used at h$mkForeignCallback+ "/** @type {*} */\nObject.mv;\n"+ ] <>+ mconcat+ (map (\x -> x <> ";\n")+ [ -- Externs needed by node environment+ "/** @type {string} */ var __dirname"+ -- Copied minimally from https://github.com/externs/nodejs/blob/6c6882c73efcdceecf42e7ba11f1e3e5c9c041f0/v8/nodejs.js#L8+ , "/** @const */ var NodeJS = {}"+ -- NodeJS Stream interface+ , "/** @interface */ NodeJS.Stream = function () {}"+ , "/** @template THIS @this {THIS} @return {THIS} */ NodeJS.Stream.prototype.on = function() {}"+ , "/** @return {boolean} */ NodeJS.Stream.prototype.write = function() {}"+ -- NodeJS versions property contains actual versions of the environment+ , "/** @interface */ NodeJS.ProcessVersions = function() {}"+ , "/** @type {string} */ NodeJS.ProcessVersions.prototype.node"+ -- NodeJS Process interface+ , "/** @interface */ NodeJS.Process = function() {}"+ , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stderr"+ , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdin"+ , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdout"+ , "/** @type {!NodeJS.ProcessVersions} */ NodeJS.Process.prototype.versions"+ , "/** @return {?} */ NodeJS.Process.prototype.exit = function() {}"+ , "/** @type {!Array<string>} */ NodeJS.Process.prototype.argv"+ -- NodeJS Process definition+ , "/** @type {!NodeJS.Process} */ var process"+ -- NodeJS Buffer class+ , "/** @extends {Uint8Array} @constructor */ function Buffer(arg1, encoding) {}"+ , "/** @return {!Buffer} */ Buffer.alloc = function() {}"+ -- Emscripten Module+ , "/** @type {*} */ var Module"+ -- Mozilla's Narcissus (JS in JS interpreter implemented on top of SpiderMonkey) environment+ , "/** @type {*} */ var putstr"+ , "/** @type {*} */ var printErr"+ -- Apples's JavaScriptCore environment+ , "/** @type {*} */ var debug"+ -- We use only Heap8 from Emscripten+ , "/** @type {!Int8Array} */ Module.HEAP8"+ ]) writeExterns :: FilePath -> IO ()-writeExterns out = writeFile (out </> "all.js.externs")+writeExterns out = writeFile (out </> "all.externs.js") $ unpackFS rtsExterns -- | Get all block dependencies for a given set of roots@@ -1095,8 +1168,9 @@ js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" let cpp_opts = CppOpts- { useHsCpp = False- , cppLinePragmas = False -- LINE pragmas aren't JS compatible+ { sourceCodePreprocessor = SCPJsCpp+ -- JS code requires keeping JSDoc comments for third party minification tooling+ , cppLinePragmas = False -- LINE pragmas aren't JS compatible } doCpp logger tmpfs
compiler/GHC/StgToJS/Linker/Utils.hs view
@@ -140,7 +140,7 @@ -- Put Addr# in ByteArray# or at Addr# (same thing) , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n"- , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n"+ , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null); var ro = (a).dv.getInt32(o,true);\n" -- Data.Maybe.Maybe , "#define HS_NOTHING h$ghczminternalZCGHCziInternalziMaybeziNothing\n"
compiler/GHC/StgToJS/Literal.hs view
@@ -115,7 +115,24 @@ 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) ]+ 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 -> JStgExpr
compiler/GHC/StgToJS/Prim.hs view
@@ -940,7 +940,7 @@ ------------------------------- Delay/Wait Ops --------------------------------- DelayOp -> \[] [t] -> pure $ PRPrimCall $ returnS (app "h$delayThread" [t])- WaitReadOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waidRead" [fd])+ WaitReadOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waitRead" [fd]) WaitWriteOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waitWrite" [fd]) ------------------------------- Concurrency Primitives -------------------------
compiler/GHC/StgToJS/Rts/Rts.hs view
@@ -371,7 +371,8 @@ , global "h$ct_stackframe" ||= toJExpr StackFrame , global "h$vt_ptr" ||= toJExpr PtrV , global "h$vt_void" ||= toJExpr VoidV- , global "h$vt_double" ||= toJExpr IntV+ , global "h$vt_int" ||= toJExpr IntV+ , global "h$vt_double" ||= toJExpr DoubleV , global "h$vt_long" ||= toJExpr LongV , global "h$vt_addr" ||= toJExpr AddrV , global "h$vt_obj" ||= toJExpr ObjV@@ -669,6 +670,10 @@ , r1 |= x , returnS (stack .! sp) ])+ , closure (ClosureInfo (global "h$reportHeapOverflow") (CIRegs 0 [PtrV]) "h$reportHeapOverflow" (CILayoutFixed 0 []) CIStackFrame mempty)+ (return $ (appS "throw" [jString "h$reportHeapOverflow: Heap Overflow!"]))+ , closure (ClosureInfo (global "h$reportStackOverflow") (CIRegs 0 [PtrV]) "h$reportStackOverflow" (CILayoutFixed 0 []) CIStackFrame mempty)+ (return $ (appS "throw" [jString "h$reportStackOverflow: Stack Overflow!"])) -- Top-level statements to generate only in profiling mode , fmap (profStat s) $ (closure (ClosureInfo (global "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) (return $
compiler/GHC/SysTools/Cpp.hs view
@@ -40,34 +40,70 @@ import System.FilePath data CppOpts = CppOpts- { useHsCpp :: !Bool- -- ^ Use the Haskell C preprocessor, otherwise use the C preprocessor.- -- See the Note [Preprocessing invocations]- , cppLinePragmas :: !Bool+ { sourceCodePreprocessor :: !SourceCodePreprocessor+ , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas } {- Note [Preprocessing invocations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must consider two distinct preprocessors when preprocessing Haskell.+We must consider four distinct preprocessors when preprocessing Haskell. These are: (1) The Haskell C preprocessor (HsCpp), which preprocesses Haskell files that make use of the CPP language extension -(2) The C preprocessor (Cpp), which is used to preprocess C and Cmm files+(2) The C preprocessor (Cpp), which is used to preprocess C files +(3) The JavaScript preprocessor (JsCpp), which preprocesses JavaScript files++(4) The C-- preprocessor (CmmCpp), which preprocesses C-- files+ These preprocessors are indeed different. Despite often sharing the same underlying program (the C compiler), the set of flags passed determines the behaviour of the preprocessor, and Cpp and HsCpp behave differently. Specifically, we rely on "traditional" (pre-standard) preprocessing semantics (which most compilers expose via the `-traditional` flag) when preprocessing-Haskell source. This avoids, e.g., the preprocessor removing C-style comments.+Haskell source. This avoids the following situations:++ * Removal of C-style comments, which are not comments in Haskell but valid+ operators;++ * Errors due to an ANSI C preprocessor lexing the source and failing on+ names with single quotes (TH quotes, ticked promoted constructors,+ names with primes in them).++ Both of those cases may be subtle: gcc and clang permit C++-style //+ comments in C code, and Data.Array and Data.Vector both export a //+ operator whose type is such that a removed "comment" may leave code that+ typechecks but does the wrong thing. Another example is that, since ANSI+ C permits long character constants, an expression involving multiple+ functions with primes in their names may not expand macros properly when+ they occur between the primed functions.++Third special type of preprocessor for JavaScript was added laterly due to+needing to keep JSDoc comments and multiline comments. Various third party+minifying software (for example, Google Closure Compiler) uses JSDoc+information to apply more strict rules to code reduction which results in+better but more dangerous minification. JSDoc comments are usually used to+instruct minifiers where dangerous optimizations could be applied.++The fourth, the C-- preprocessor, is needed as modern compilers emit defines+for debug info generation when preprocessing. The C-- preprocessor avoids this+by suppressing debug info generation. The C-- preprocessor also inherits flags+passed to the C compiler. This is done for compatibility. Following those,+the C-- compiler receives -g0, if it was detected as supported, and flags+passed via -optCmmP specifically for the C-- preprocessor. The combined+command line looks like:++ $pgmCmmP $optCs_without_g3s $g0_if_supported $optCmmP+ -} --- | Run either the Haskell preprocessor or the C preprocessor, as per the--- 'CppOpts' passed. See Note [Preprocessing invocations].+-- | Run either the Haskell preprocessor, JavaScript preprocessor+-- or the C preprocessor, as per the 'CppOpts' passed.+-- See Note [Preprocessing invocations]. -- -- UnitEnv is needed to compute MIN_VERSION macros doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO ()@@ -95,9 +131,7 @@ let verbFlags = getVerbFlags dflags - let cpp_prog args- | useHsCpp opts = GHC.SysTools.runHsCpp logger dflags args- | otherwise = GHC.SysTools.runCpp logger tmpfs dflags args+ let cpp_prog args = runSourceCodePreprocessor logger tmpfs dflags (sourceCodePreprocessor opts) args let platform = targetPlatform dflags targetArch = stringEncodeArch $ platformArch platform@@ -225,11 +259,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
compiler/GHC/SysTools/Tasks.hs view
@@ -107,32 +107,75 @@ | "warning: call-clobbered register used" `isContainedIn` w = False | otherwise = True --- | Run the C preprocessor, which is different from running the--- Haskell C preprocessor (they're configured separately!).--- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp-runCpp :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runCpp logger tmpfs dflags args = traceSystoolCommand logger "cpp" $ do- let (p,args0) = pgm_cpp dflags- userOpts_c = map Option $ getOpts dflags opt_c- args2 = args0 ++ args ++ userOpts_c- mb_env <- getGccEnv args2- runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter "C pre-processor" p- args2 mb_env+-- | See the Note [Preprocessing invocations]+data SourceCodePreprocessor+ = SCPCpp+ -- ^ Use the ordinary C preprocessor+ | SCPHsCpp+ -- ^ Use the Haskell C preprocessor (don't remove C comments, don't break on names including single quotes)+ | SCPJsCpp+ -- ^ Use the JavaScript preprocessor (don't remove jsdoc and multiline comments)+ | SCPCmmCpp+ -- ^ Use the C-- preprocessor (don't emit debug information)+ deriving (Eq) --- | Run the Haskell C preprocessor.+-- | Run source code preprocessor. -- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp-runHsCpp :: Logger -> DynFlags -> [Option] -> IO ()-runHsCpp logger dflags args = traceSystoolCommand logger "hs-cpp" $ do- let (p,args0) = pgm_P dflags- opts = getOpts dflags opt_P- modified_imports = augmentImports dflags opts- args1 = map Option modified_imports+runSourceCodePreprocessor+ :: Logger+ -> TmpFs+ -> DynFlags+ -> SourceCodePreprocessor+ -> [Option]+ -> IO ()+runSourceCodePreprocessor logger tmpfs dflags preprocessor args =+ traceSystoolCommand logger logger_name $ do+ let+ (p, args0) = pgm_getter dflags+ args1 = Option <$> (augmentImports dflags $ getOpts dflags opt_getter) args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]- mb_env <- getGccEnv args2 -- romes: what about args0 and args?- runSomethingFiltered logger id "Haskell C pre-processor" p- (args0 ++ args1 ++ args2 ++ args) Nothing mb_env+ all_args = args0 ++ args1 ++ args2 ++ args + mb_env <- getGccEnv (args0 ++ args1)++ runSomething readable_name p all_args mb_env++ where+ toolSettings' = toolSettings dflags+ cmmG0 = ["-g0" | toolSettings_cmmCppSupportsG0 toolSettings']+ -- GCC <=10 (pre commit r11-5596-g934a54180541d2) implied -dD for debug+ -- flags by the spec snippet %{g3|ggdb3|gstabs3|gxcoff3|gvms3:-dD}. This+ -- means that a g0 will not override a previously-specified -g3 causing+ -- debug info emission (see https://gcc.gnu.org/PR97989). We're filtering+ -- -optc here, rather than the combined command line, in order to avoid an+ -- issue where a user has to, for some reason, override our decision. If+ -- they see the need to do that, they can pass -optCmmP.+ g3Flags = ["-g3", "-ggdb3", "-gstabs3", "-gxcoff3", "-gvms3"]+ optCFiltered = filter (`notElem` g3Flags) . opt_c+ -- In the wild (and GHC), there is lots of code assuming that -optc gets+ -- passed to the C-- preprocessor too. Note that the arguments are+ -- reversed by getOpts.+ cAndCmmOpt dflags = opt_CmmP dflags ++ cmmG0 ++ optCFiltered dflags+ (logger_name, pgm_getter, opt_getter, readable_name)+ = case preprocessor of+ SCPCpp -> ("cpp", pgm_cpp, opt_c, "C pre-processor")+ SCPHsCpp -> ("hs-cpp", pgm_P, opt_P, "Haskell C pre-processor")+ SCPJsCpp -> ("js-cpp", pgm_JSP, opt_JSP, "JavaScript C pre-processor")+ SCPCmmCpp -> ("cmm-cpp", pgm_CmmP, cAndCmmOpt, "C-- C pre-processor")++ runSomethingResponseFileCpp+ = runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter+ runSomethingFilteredOther phase_name pgm args mb_env+ = runSomethingFiltered logger id phase_name pgm args Nothing mb_env++ runSomething+ = case preprocessor of+ SCPCpp -> runSomethingResponseFileCpp+ SCPHsCpp -> runSomethingFilteredOther+ SCPJsCpp -> runSomethingFilteredOther+ SCPCmmCpp -> runSomethingResponseFileCpp+ runPp :: Logger -> DynFlags -> [Option] -> IO () runPp logger dflags args = traceSystoolCommand logger "pp" $ do let prog = pgm_F dflags@@ -243,14 +286,17 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version- LLVM (http://llvm.org/):- LLVM version 3.5.2+ <vendor> LLVM version 15.0.7 ...+ OR+ LLVM (http://llvm.org/):+ LLVM version 14.0.6 -} hSetBinaryMode pout False- _ <- hGetLine pout- vline <- hGetLine pout- let mb_ver = parseLlvmVersion vline+ line1 <- hGetLine pout+ mb_ver <- case parseLlvmVersion line1 of+ mb_ver@(Just _) -> return mb_ver+ Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line hClose pin hClose pout hClose perr
compiler/GHC/Tc/Errors.hs view
@@ -465,6 +465,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@@ -2094,10 +2096,9 @@ case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> (TypeEqMismatch- { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds- , teq_mismatch_item = item- , teq_mismatch_ty1 = ty1- , teq_mismatch_ty2 = ty2+ { teq_mismatch_item = item+ , teq_mismatch_ty1 = ty1+ , teq_mismatch_ty2 = ty2 , teq_mismatch_actual = uo_actual , teq_mismatch_expected = uo_expected , teq_mismatch_what = mb_thing@@ -2121,26 +2122,7 @@ where orig = errorItemOrigin item mb_same_occ = sameOccExtras ty2 ty1- ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)--- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments.------ This function first checks to see if the 'CtOrigin' argument is a--- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible--- equality; if it's not, definitely print the kinds. Even if the equality is--- a visible equality, check the expected/actual types to see if the types--- have equal visible components. If the 'CtOrigin' is--- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.-shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool-shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act- , uo_expected = exp- , uo_visible = vis })- | not vis = True -- See tests T15870, T16204c- | otherwise = tcEqTypeVis act exp -- See tests T9171, T9144.-shouldPprWithExplicitKinds ty1 ty2 _ct- = tcEqTypeVis ty1 ty2- {- Note [Insoluble mis-match] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble@@ -2401,29 +2383,6 @@ Perhaps you meant ‘getAlt’ (imported from Data.Monoid) Perhaps you want to add ‘getAll’ to the import list in the import of ‘Data.Monoid’--}--{--Note [Kind arguments in error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It can be terribly confusing to get an error message like (#9171)-- Couldn't match expected type ‘GetParam Base (GetParam Base Int)’- with actual type ‘GetParam Base (GetParam Base Int)’--The reason may be that the kinds don't match up. Typically you'll get-more useful information, but not when it's as a result of ambiguity.--To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag-whenever any error message arises due to a kind mismatch. This means that-the above error message would instead be displayed as:-- Couldn't match expected type- ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’- with actual type- ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’--Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. -} -----------------------
compiler/GHC/Tc/Gen/App.hs view
@@ -56,7 +56,6 @@ import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )-import GHC.Types.SourceText import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable@@ -899,18 +898,12 @@ where unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e)- go (L l e@(HsOverLit _ lit)) =- do { tylit <- case ol_val lit of- HsIntegral n -> return $ HsNumTy NoSourceText (il_value n)- HsIsString _ s -> return $ HsStrTy NoSourceText s- HsFractional _ -> failWith $ TcRnIllformedTypeArgument (L l e)- ; return (L l (HsTyLit noExtField tylit)) }- go (L l e@(HsLit _ lit)) =- do { tylit <- case lit of- HsChar _ c -> return $ HsCharTy NoSourceText c- HsString _ s -> return $ HsStrTy NoSourceText s- _ -> failWith $ TcRnIllformedTypeArgument (L l e)- ; return (L l (HsTyLit noExtField tylit)) }+ go (L l (HsOverLit _ lit))+ | Just tylit <- tyLitFromOverloadedLit (ol_val lit)+ = return (L l (HsTyLit noExtField tylit))+ go (L l (HsLit _ lit))+ | Just tylit <- tyLitFromLit lit+ = return (L l (HsTyLit noExtField tylit)) go (L l (ExplicitTuple _ tup_args boxity)) -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted | isBoxed boxity
compiler/GHC/Tc/Gen/Bind.hs view
@@ -723,7 +723,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@@ -735,17 +734,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@@ -762,7 +779,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))@@ -1871,12 +1888,17 @@ -- See Note [Always generalise top-level bindings] | has_mult_anns_and_pats = False- -- See Note [Non-variable pattern bindings aren't linear]+ -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] - | IsGroupClosed _ True <- closed = True+ | IsGroupClosed _ True <- closed+ , not (null binders) = True -- The 'True' means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore- -- -XMonoLocalBinds, and generalise anyway+ -- -XMonoLocalBinds, and generalise anyway.+ -- Except if 'fv' is empty: there is no binder to generalise, so+ -- generalising does nothing. And trying to generalise hurts linear+ -- types (see #25428). So we don't force it.+ -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. | has_partial_sigs = True -- See Note [Partial type signatures and generalisation]
compiler/GHC/Tc/Gen/Head.hs view
@@ -37,8 +37,6 @@ import GHC.Hs.Syn.Type import GHC.Tc.Gen.HsType-import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )- import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )@@ -78,15 +76,14 @@ import GHC.Builtin.Names import GHC.Builtin.Names.TH( liftStringName, liftName ) -import GHC.Driver.Env import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import Control.Monad+import GHC.Rename.Unbound (WhatLooking(WL_Anything)) @@ -1164,46 +1161,11 @@ AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps- (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon- ATyVar name _ -> fail_tyvar name+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon+ ATyVar name _ -> failIllegalTyVal name _ -> failWithTc $ TcRnExpectedValueId thing } where- fail_tycon tc = do- gre <- getGlobalRdrEnv- let nm = tyConName tc- pprov = case lookupGRE_Name gre nm of- Just gre -> nest 2 (pprNameProvenance gre)- Nothing -> empty- err | isClassTyCon tc = ClassTE- | otherwise = TyConTE- fail_with_msg dataName nm pprov err-- fail_tyvar nm =- let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))- in fail_with_msg varName nm pprov TyVarTE-- fail_with_msg whatName nm pprov err = do- (import_errs, hints) <- get_suggestions whatName- unit_state <- hsc_units <$> getTopEnv- let- -- TODO: unfortunate to have to convert to SDoc here.- -- This should go away once we refactor ErrInfo.- hint_msg = vcat $ map ppr hints- import_err_msg = vcat $ map ppr import_errs- info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }- failWithTc $ TcRnMessageWithInfo unit_state (- mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))-- get_suggestions ns = do- required_type_arguments <- xoptM LangExt.RequiredTypeArguments- if required_type_arguments && isVarNameSpace ns- then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments]- else do- let occ = mkOccNameFS ns (occNameFS (occName id_name))- lcl_env <- getLocalRdrEnv- unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ)- return_id id = return (HsVar noExtField (noLocA id), idType id) {- Note [Suppress hints with RequiredTypeArguments]
compiler/GHC/Tc/Gen/HsType.hs view
@@ -73,7 +73,10 @@ HoleMode(..), -- Error messages- funAppCtxt, addTyConFlavCtxt+ funAppCtxt, addTyConFlavCtxt,++ -- Utils+ tyLitFromLit, tyLitFromOverloadedLit, ) where import GHC.Prelude hiding ( head, init, last, tail )@@ -140,6 +143,7 @@ import Data.List ( mapAccumL ) import Control.Monad import Data.Tuple( swap )+import GHC.Types.SourceText {- ----------------------------@@ -4687,3 +4691,22 @@ addTyConFlavCtxt name flav = addErrCtxt $ hsep [ text "In the", ppr flav , text "declaration for", quotes (ppr name) ]++{-+************************************************************************+* *+ Utils for constructing TyLit+* *+************************************************************************+-}+++tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn)+tyLitFromLit (HsString x str) = Just (HsStrTy x str)+tyLitFromLit (HsChar x char) = Just (HsCharTy x char)+tyLitFromLit _ = Nothing++tyLitFromOverloadedLit :: OverLitVal -> Maybe (HsTyLit GhcRn)+tyLitFromOverloadedLit (HsIntegral n) = Just $ HsNumTy NoSourceText (il_value n)+tyLitFromOverloadedLit (HsIsString _ s) = Just $ HsStrTy NoSourceText s+tyLitFromOverloadedLit HsFractional{} = Nothing
compiler/GHC/Tc/Gen/Match.hs view
@@ -501,6 +501,32 @@ -- coercion matching stuff in them. It's hard to avoid the -- potential for non-trivial coercions in tcMcStmt +{-+Note [Binding in list comprehension isn't linear]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`.+But, the way the desugaring works, we get something like++case xs of+ () : xs ' -> letrec next_stmt = … xs' …++In the current typing rules for letrec in Core, next_stmt is necessarily of+multiplicity Many and so is every free variable, including xs'. Which, in turns,+requires xs to be of multiplicity Many.++Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having+non-Many multiplicities. But it's a fair bit of work to implement.++Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then+we just conservatively make it unrestricted instead.++If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]]+isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have+to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh+multiplicity variable. We'd also use the same multiplicity variable in the call+to `tcCheckPat` instead of `unrestricted`.+-}+ tcLcStmt :: TyCon -- The list type constructor ([]) -> TcExprStmtChecker @@ -512,20 +538,24 @@ -- A generator, pat <- rhs tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind- ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])+ -- About the next `tcScalingUsage ManyTy` and unrestricted+ -- see Note [Binding in list comprehension isn't linear]+ ; rhs' <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $+ tcScalingUsage ManyTy $ thing_inside elt_ty ; return (mkTcBindStmt pat' rhs', thing) } -- A boolean guard tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside = do { rhs' <- tcCheckMonoExpr rhs boolTy- ; thing <- thing_inside elt_ty+ ; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } -- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions] tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside- = do { env <- getLocalRdrEnv+ = tcScalingUsage ManyTy $ -- parallel list comprehension never desugars to something linear.+ do { env <- getLocalRdrEnv ; (pairs', thing) <- loop env [] bndr_stmts_s ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } where@@ -551,7 +581,8 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap , trS_by = by, trS_using = using }) elt_ty thing_inside- = do { let (bndr_names, n_bndr_names) = unzip bindersMap+ = tcScalingUsage ManyTy $ -- Transform statements are too complex: just make everything multiplicity Many+ do { let (bndr_names, n_bndr_names) = unzip bindersMap unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) -- The inner 'stmts' lack a LastStmt, so the element type -- passed in to tcStmtsAndThen is never looked at
compiler/GHC/Tc/Gen/Pat.hs view
@@ -78,6 +78,8 @@ import Data.List( partition ) import Data.Maybe (isJust)+import Control.Monad.Trans.Writer.CPS+import Control.Monad.Trans.Class {- ************************************************************************@@ -504,55 +506,108 @@ ; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty tp) ; return (pat', result) } + -- Convert a Pat into the equivalent HsTyPat. -- See `expr_to_type` (GHC.Tc.Gen.App) for the HsExpr counterpart. -- The `TcM` monad is only used to fail on ill-formed type patterns. pat_to_type_pat :: Pat GhcRn -> TcM (HsTyPat GhcRn)-pat_to_type_pat (EmbTyPat _ tp) = return tp-pat_to_type_pat (VarPat _ lname) = return (HsTP x b)+pat_to_type_pat pat = do+ (ty, x) <- runWriterT (pat_to_type pat)+ pure (HsTP (buildHsTyPatRn x) ty)++pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)+pat_to_type (EmbTyPat _ (HsTP x t)) =+ do { tell (builderFromHsTyPatRn x)+ ; return t }+pat_to_type (VarPat _ lname) =+ do { tell (tpBuilderExplicitTV (unLoc lname))+ ; return b } where b = noLocA (HsTyVar noAnn NotPromoted lname)- x = HsTPRn { hstp_nwcs = []- , hstp_imp_tvs = []- , hstp_exp_tvs = [unLoc lname] }-pat_to_type_pat (WildPat _) = return (HsTP x b)+pat_to_type (WildPat _) = return b where b = noLocA (HsWildCardTy noExtField)- x = HsTPRn { hstp_nwcs = []- , hstp_imp_tvs = []- , hstp_exp_tvs = [] }-pat_to_type_pat (SigPat _ pat sig_ty)- = do { HsTP x_hstp t <- pat_to_type_pat (unLoc pat)+pat_to_type (SigPat _ pat sig_ty)+ = do { t <- pat_to_type (unLoc pat) ; let { !(HsPS x_hsps k) = sig_ty- ; x = append_hstp_hsps x_hstp x_hsps ; b = noLocA (HsKindSig noAnn t k) }- ; return (HsTP x b) }- where- -- Quadratic for nested signatures ((p :: t1) :: t2)- -- but those are unlikely to occur in practice.- append_hstp_hsps :: HsTyPatRn -> HsPSRn -> HsTyPatRn- append_hstp_hsps t p- = HsTPRn { hstp_nwcs = hstp_nwcs t ++ hsps_nwcs p- , hstp_imp_tvs = hstp_imp_tvs t ++ hsps_imp_tvs p- , hstp_exp_tvs = hstp_exp_tvs t }-pat_to_type_pat (ParPat _ pat)- = do { HsTP x t <- pat_to_type_pat (unLoc pat)- ; return (HsTP x (noLocA (HsParTy noAnn t))) }-pat_to_type_pat (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do- { HsTP x t <- pat_to_type_pat pat- ; return (HsTP x (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice))) }-pat_to_type_pat pat =- -- There are other cases to handle (ConPat, ListPat, TuplePat, etc), but these- -- would always be rejected by the unification in `tcHsTyPat`, so it's fine to- -- skip them here. This won't continue to be the case when visible forall is- -- permitted in data constructors:- --- -- data T a where { Typed :: forall a -> a -> T a }- -- g :: T Int -> Int- -- g (Typed Int x) = x -- Note the `Int` type pattern- --- -- See ticket #18389. When this feature lands, it would be best to extend- -- `pat_to_type_pat` to handle as many pattern forms as possible.+ ; tell (tpBuilderPatSig x_hsps)+ ; return b }+pat_to_type (ParPat _ pat)+ = do { t <- pat_to_type (unLoc pat)+ ; return (noLocA (HsParTy noAnn t)) }+pat_to_type (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do+ { t <- pat_to_type pat+ ; return (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice)) }++pat_to_type (TuplePat _ pats Boxed)+ = do { tys <- traverse (pat_to_type . unLoc) pats+ ; let t = noLocA (HsExplicitTupleTy noExtField tys)+ ; pure t }+pat_to_type (ListPat _ pats)+ = do { tys <- traverse (pat_to_type . unLoc) pats+ ; let t = noLocA (HsExplicitListTy NoExtField NotPromoted tys)+ ; pure t }++pat_to_type (LitPat _ lit)+ | Just ty_lit <- tyLitFromLit lit+ = do { let t = noLocA (HsTyLit noExtField ty_lit)+ ; pure t }+pat_to_type (NPat _ (L _ lit) _ _)+ | Just ty_lit <- tyLitFromOverloadedLit (ol_val lit)+ = do { let t = noLocA (HsTyLit noExtField ty_lit)+ ; pure t}++pat_to_type (ConPat _ lname (InfixCon left right))+ = do { lty <- pat_to_type (unLoc left)+ ; rty <- pat_to_type (unLoc right)+ ; let { t = noLocA (HsOpTy noAnn NotPromoted lty lname rty)}+ ; pure t }+pat_to_type (ConPat _ lname (PrefixCon invis_args vis_args))+ = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname)}+ ; ty_invis <- foldM apply_invis_arg appHead invis_args+ ; tys_vis <- traverse (pat_to_type . unLoc) vis_args+ ; let t = foldl' mkHsAppTy ty_invis tys_vis+ ; pure t }+ where+ apply_invis_arg :: LHsType GhcRn -> HsConPatTyArg GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)+ apply_invis_arg !t (HsConPatTyArg _ (HsTP argx arg))+ = do { tell (builderFromHsTyPatRn argx)+ ; pure (mkHsAppKindTy noExtField t arg)}++pat_to_type pat = lift $ failWith $ TcRnIllformedTypePattern pat -- This failure is the only use of the TcM monad in `pat_to_type_pat`++{-+Note [Pattern to type (P2T) conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++ data T a b where+ MkT :: forall a. forall b -> a -> b -> T a b+ -- NB: `a` is invisible, but `b` is required++ f (MkT @[Int] (Maybe Bool) x y) = ...++The second type argument of `MkT` is Required, so we write it without+an `@` sign in the pattern match. So the (Maybe Bool) will be+ * parsed and renamed as a term pattern+ * converted to a type when typechecking the pattern-match: the P2T conversion++This is the only place we have P2T. In type-lambdas, the "pattern" is always a+type variable:++ f :: forall a -> a -> blah+ f b (x::b) = ...++The `b` argument must be a simple variable; we can't pattern-match on types.++The function `pat_to_type` does the P2T conversion:+ pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)++It is arranged as a writer monad, where the `HsTyPatRnBuilder` accumulates the+binders bound by the type. (We could discover these binders by a subsequent+traversal, that would mean writing another traversal.)+-} tc_ty_pat :: HsTyPat GhcRn -> TcTyVar -> TcM r -> TcM (TcType, r) tc_ty_pat tp tv thing_inside
compiler/GHC/Tc/Instance/Family.hs view
@@ -58,6 +58,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Env (unitEnv_hpts)+import Data.List (sortOn) {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -239,6 +240,49 @@ a set of utility modules that every module imports directly or indirectly. This is basically the idea from #13092, comment:14.++Note [Order of type family consistency checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a module M which imports modules A, B and C, all defining (open) type+family instances.++We can waste a lot of work in type family consistency checking depending on the+order in which the modules are processed.++Suppose for example that C imports A and B. When we compiled C, we will have+checked A and B for consistency against eachother. This means that, when+processing the imports of M to check type family instance consistency:++* if C is processed first, then A and B will not need to be checked for+ consistency against eachother again,+* if we process A and B before C,then the+ consistency checks between A and B will be performed again. This is wasted+ work, as we already performed them for C.++This can make a significant difference. Keeping the nomenclature of the above+example for illustration, we have observed situations in practice in which the+compilation time of M goes from 1 second (the "processing A and B first" case)+down to 80 milliseconds (the "processing C first" case).++Clearly we should engineer that C is checked before B and A, but by what scheme?++A simple one is to observe that if a module M is in the transitive closure of X+then the size of the consistent family set of M is less than or equal to size+of the consistent family set of X.++Therefore, by sorting the imports by the size of the consistent family set and+processing the largest first, we make sure to process modules in topological+order.++For a particular project, without this change we did 40 million checks and with+this change we did 22.9 million checks. This is significant as before this change+type family consistency checks accounted for 26% of total type checker allocations which+was reduced to 15%.++See tickets #25554 for discussion about this exact issue and #25555 for+why we still do redundant checks.+ -} -- We don't need to check the current module, this is done in@@ -267,6 +311,12 @@ where deps = dep_finsts . mi_deps . modIface $ mod + ; debug_consistent_set = map (\x -> (x, length (modConsistent x))) directlyImpMods++ -- Sorting the list by size has the effect of performing a topological sort.+ -- See Note [Order of type family consistency checks]+ ; init_consistent_set = reverse (sortOn (length . modConsistent) directlyImpMods)+ ; hmiModule = mi_module . hm_iface ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . md_fam_insts . hm_details@@ -276,7 +326,8 @@ } - ; checkMany hpt_fam_insts modConsistent directlyImpMods+ ; traceTc "init_consistent_set" (ppr debug_consistent_set)+ ; checkMany hpt_fam_insts modConsistent init_consistent_set } where -- See Note [Checking family instance optimization]@@ -294,6 +345,11 @@ -> TcM () go _ _ [] = return () go consistent consistent_set (mod:mods) = do+ traceTc "checkManySize" (vcat [text "mod:" <+> ppr mod+ , text "m1:" <+> ppr (length to_check_from_mod)+ , text "m2:" <+> ppr (length (to_check_from_consistent))+ , text "product:" <+> ppr (length to_check_from_mod * length to_check_from_consistent)+ ]) sequence_ [ check hpt_fam_insts m1 m2 | m1 <- to_check_from_mod
compiler/GHC/Tc/Module.hs view
@@ -434,7 +434,9 @@ ; let { dir_imp_mods = moduleEnvKeys . imp_mods $ imports }- ; checkFamInstConsistency dir_imp_mods+ ; logger <- getLogger+ ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ())+ $ checkFamInstConsistency dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; getGblEnv } }@@ -709,7 +711,7 @@ -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs)- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds+ <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds ; setGblEnv tcg_env $ do { -- Emit Typeable bindings@@ -1612,7 +1614,7 @@ traceTc "Tc3" empty ; (tcg_env, inst_infos, th_bndrs, XValBindsLR (NValBinds deriv_binds deriv_sigs))- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;+ <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ; updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ setGblEnv tcg_env $ do {@@ -1622,11 +1624,6 @@ (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { - -- Default declarations- traceTc "Tc4a" empty ;- default_tys <- tcDefaults default_decls ;- updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {- -- Value declarations next. -- It is important that we check the top-level value bindings -- before the GHC-generated derived bindings, since the latter@@ -1686,13 +1683,14 @@ addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; return (tcg_env', tcl_env)- }}}}}}+ }}}}} tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" --------------------------- tcTyClsInstDecls :: [TyClGroup GhcRn] -> [LDerivDecl GhcRn]+ -> [LDefaultDecl GhcRn] -> [(RecFlag, LHsBinds GhcRn)] -> TcM (TcGblEnv, -- The full inst env [InstInfo GhcRn], -- Source-code instance decls to@@ -1702,16 +1700,24 @@ HsValBinds GhcRn) -- Supporting bindings for derived -- instances -tcTyClsInstDecls tycl_decls deriv_decls binds+tcTyClsInstDecls tycl_decls deriv_decls default_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $ do { (tcg_env, inst_info, deriv_info, th_bndrs) <- tcTyAndClassDecls tycl_decls ;+ ; setGblEnv tcg_env $ do {+ -- With the @TyClDecl@s and @InstDecl@s checked we're ready to -- process the deriving clauses, including data family deriving -- clauses discovered in @tcTyAndClassDecls@. --+ -- But only after we've typechecked 'default' declarations.+ -- See Note [Typechecking default declarations]+ default_tys <- tcDefaults default_decls ;+ updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {++ -- Careful to quit now in case there were instance errors, so that -- the deriving errors don't pile up as well. ; failIfErrsM@@ -1720,7 +1726,7 @@ ; setGblEnv tcg_env' $ do { failIfErrsM ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds )- }}}+ }}}} {- ********************************************************************* * *@@ -3141,3 +3147,43 @@ pluginUnsafe = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin+++-- Note [Typechecking default declarations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Typechecking default declarations requires careful placement:+--+-- 1. We must check them after types (tcTyAndClassDecls) because they can refer+-- to them. E.g.+--+-- data T = MkT ...+-- default(Int, T, Integer)+--+-- -- or even (tested by T11974b and T2245)+-- default(Int, T, Integer)+-- data T = MkT ...+--+-- 2. We must check them before typechecking deriving clauses (tcInstDeclsDeriv)+-- otherwise we may lookup default default types (Integer, Double) while checking+-- deriving clauses, ignoring the default declaration.+--+-- Before this careful placement (#24566), compiling the following example+-- (T24566) with "-ddump-if-trace -ddump-tc-trace" showed a call to+-- `applyDefaultingRules` with default types set to "(Integer,Double)":+--+-- module M where+--+-- import GHC.Classes+-- default ()+--+-- data Foo a = Nothing | Just a+-- deriving (Eq, Ord)+--+-- This was an issue while building modules like M in the ghc-internal package+-- because they would spuriously fail to build if the module defining Integer+-- (ghc-bignum:GHC.Num.Integer) wasn't compiled yet and its interface not to be+-- found. The implicit dependency between M and GHC.Num.Integer isn't known to+-- the build system.+-- In addition, trying to explicitly avoid the implicit dependency with `default+-- ()` didn't work, except if *standalone* deriving was used, which was an+-- inconsistent behavior.
compiler/GHC/Tc/Solver/Equality.hs view
@@ -311,7 +311,7 @@ -> Type -> Type -- RHS, after and before type-synonym expansion, resp -> TcS (StopOrContinue (Either IrredCt EqCt)) --- See Note [Comparing nullary type synonyms] in GHC.Core.Type.+-- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2 | tc1 == tc2 = canEqReflexive ev eq_rel ty1@@ -2228,7 +2228,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. @@ -2900,8 +2900,7 @@ type instance F (a, Int) = (Int, G a) where G is injective; and wanted constraints - [W] TF (alpha, beta) ~ fuv- [W] fuv ~ (Int, <some type>)+ [W] F (alpha, beta) ~ (Int, <some type>) The injectivity will give rise to constraints @@ -2917,8 +2916,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@@ -2999,8 +2998,9 @@ | otherwise = do { fam_envs <- getFamInstEnvs ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs- ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs- , ppr eqns ])+ ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args+ , text "rhs:" <+> ppr rhs+ , text "eqns:" <+> ppr eqns ]) ; unifyFunDeps ev Nominal $ \uenv -> uPairsTcM (bump_depth uenv) (reverse eqns) } -- Missing that `reverse` causes T13135 and T13135_simple to loop.@@ -3072,17 +3072,17 @@ -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch) -> TcS [TypeEqn] injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)- = do { subst <- instFlexiX subst unsubstTvs+ = do { 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. - ; return [ Pair (substTy subst ax_arg) arg+ ; return [ Pair (substTy subst1 ax_arg) arg -- NB: the ax_arg part is on the left -- see Note [Improvement orientation] | case cabr of- Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'+ Just cabr' -> apartnessCheck (substTys subst1 ax_args) cabr' _ -> True , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
compiler/GHC/Tc/Utils/Env.hs view
@@ -28,6 +28,7 @@ tcLookupLocatedClass, tcLookupAxiom, lookupGlobal, lookupGlobal_maybe, addTypecheckedBinds,+ failIllegalTyCon, failIllegalTyVal, -- Local environment tcExtendKindEnv, tcExtendKindEnvList,@@ -137,6 +138,7 @@ import Control.Monad import GHC.Iface.Errors.Types import GHC.Types.Error+import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) {- ********************************************************************* * *@@ -278,6 +280,7 @@ thing <- tcLookupGlobal name case thing of AConLike cl -> return cl+ ATyCon tc -> failIllegalTyCon WL_Constructor tc _ -> wrongThingErr WrongThingConLike (AGlobal thing) name tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent@@ -349,6 +352,45 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where lookupThing = tcLookupGlobal +-- Illegal term-level use of type things+failIllegalTyCon :: WhatLooking -> TyCon -> TcM a+failIllegalTyVal :: Name -> TcM a+(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)+ where+ fail_tycon what_looking tc = do+ gre <- getGlobalRdrEnv+ let nm = tyConName tc+ pprov = case lookupGRE_Name gre nm of+ Just gre -> nest 2 (pprNameProvenance gre)+ Nothing -> empty+ err | isClassTyCon tc = ClassTE+ | otherwise = TyConTE+ fail_with_msg what_looking dataName nm pprov err++ fail_tyvar nm =+ let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))+ in fail_with_msg WL_Anything varName nm pprov TyVarTE++ fail_with_msg what_looking whatName nm pprov err = do+ (import_errs, hints) <- get_suggestions what_looking whatName nm+ unit_state <- hsc_units <$> getTopEnv+ let+ -- TODO: unfortunate to have to convert to SDoc here.+ -- This should go away once we refactor ErrInfo.+ hint_msg = vcat $ map ppr hints+ import_err_msg = vcat $ map ppr import_errs+ info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }+ failWithTc $ TcRnMessageWithInfo unit_state (+ mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))++ get_suggestions what_looking ns nm = do+ required_type_arguments <- xoptM LangExt.RequiredTypeArguments+ if required_type_arguments && isVarNameSpace ns+ then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments]+ else do+ let occ = mkOccNameFS ns (occNameFS (occName nm))+ lcl_env <- getLocalRdrEnv+ unknownNameSuggestions lcl_env what_looking (mkRdrUnqual occ) {- ************************************************************************ * *@@ -888,7 +930,7 @@ {- Note [Extended defaults]-~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~ In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we try when defaulting. This has very little real impact, except in the following case. Consider:
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -11,7 +11,7 @@ -} module GHC.Tc.Utils.Instantiate (- topSkolemise,+ topSkolemise, skolemiseRequired, topInstantiate, instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith,@@ -75,7 +75,7 @@ import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Types.Id.Make( mkDictFunId )-import GHC.Types.Basic ( TypeOrKind(..), Arity )+import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity ) import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc@@ -145,22 +145,16 @@ Note [Skolemisation] ~~~~~~~~~~~~~~~~~~~~ topSkolemise decomposes and skolemises a type, returning a type-with no top level foralls or (=>)+with no top level foralls or (=>). Examples: topSkolemise (forall a. Ord a => a -> a) = ( wp, [a], [d:Ord a], a->a )- where wp = /\a. \(d:Ord a). <hole> a d-- topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b)- = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b )- where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). <hole> a d1 b d2+ where+ wp = /\a. \(d:Ord a). <hole> a d -This second example is the reason for the recursive 'go' function in-topSkolemise: we remove successive layers of foralls and (=>). This-is really just an optimisation; see wrinkle (SK1) in GHC.Tc.Utils.Unify-Note [Skolemisation overview].+For nested foralls, see Note [Skolemisation en-bloc] In general, if topSkolemise ty = (wrap, tvs, evs, rho)@@ -168,6 +162,41 @@ then wrap e :: ty and 'wrap' binds {tvs, evs} +Note [Skolemisation en-bloc]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this case:++ topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b)++We /could/ return just+ (wp, [a], [d:Ord a, forall b. Eq b => a -> b -> b)++But in fact we skolemise "en-bloc", looping around (in `topSkolemise` for+example) to skolemise the (forall b. Eq b =>). So in fact++ topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b)+ = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b )+ where+ wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). <hole> a d1 b d2++This applies regardless of DeepSubsumption.++Why do we do this "en-bloc" loopy thing? It is /nearly/ just an optimisation.+But not quite! At the call site of `topSkolemise` (and its cousins) we+use `checkConstraints` to gather constraints and build an implication+constraint. So skolemising just one level at a time would lead to nested+implication constraints. That is a bit less efficient, but there is /also/ a small+user-visible effect: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet.+Specifically, consider++ forall a. Eq a => forall b. (a ~ [b]) => blah++If we skolemise en-bloc, the equality (a~[b]) is like a let-binding and we+don't treat it like a GADT pattern match, limiting unification. With nested+implications, the inner one would be treated as having-given-equalities.++This is also relevant when Required foralls are involved; see #24810, and+the loop in `skolemiseRequired`. -} topSkolemise :: SkolemInfo@@ -182,7 +211,7 @@ where init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - -- Why recursive? See Note [Skolemisation]+ -- Why recursive? See Note [Skolemisation en-bloc] go subst wrap tv_prs ev_vars ty | (bndrs, theta, inner_ty) <- tcSplitSigmaTyBndrs ty , let tvs = binderVars bndrs@@ -200,6 +229,51 @@ | otherwise = return (wrap, tv_prs, ev_vars, substTy subst ty)+ -- substTy is a quick no-op on an empty substitution++skolemiseRequired :: SkolemInfo -> VisArity -> TcSigmaType+ -> TcM (VisArity, HsWrapper, [Name], [ForAllTyBinder], [EvVar], TcRhoType)+-- Skolemise up to N required (visible) binders,+-- plus any invisible ones "in the way",+-- /and/ any trailing invisible ones.+-- So the result has no top-level invisible quantifiers.+-- Return the depleted arity.+skolemiseRequired skolem_info n_req sigma+ = go n_req init_subst idHsWrapper [] [] [] sigma+ where+ init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma))++ -- Why recursive? See Note [Skolemisation en-bloc]+ go n_req subst wrap acc_nms acc_bndrs ev_vars ty+ | (n_req', bndrs, inner_ty) <- tcSplitForAllTyVarsReqTVBindersN n_req ty+ , not (null bndrs)+ = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs+ ; let tvs1 = binderVars bndrs1+ -- fix_up_vis: see Note [Required foralls in Core]+ -- in GHC.Core.TyCo.Rep+ fix_up_vis | n_req == n_req'+ = idHsWrapper+ | otherwise+ = mkWpForAllCast bndrs1 (substTy subst' inner_ty)+ ; go n_req' subst'+ (wrap <.> fix_up_vis <.> mkWpTyLams tvs1)+ (acc_nms ++ map (tyVarName . binderVar) bndrs)+ (acc_bndrs ++ bndrs1)+ ev_vars+ inner_ty }++ | (theta, inner_ty) <- tcSplitPhiTy ty+ , not (null theta)+ = do { ev_vars1 <- newEvVars (substTheta subst theta)+ ; go n_req subst+ (wrap <.> mkWpEvLams ev_vars1)+ acc_nms+ acc_bndrs+ (ev_vars ++ ev_vars1)+ inner_ty }++ | otherwise+ = return (n_req, wrap, acc_nms, acc_bndrs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
compiler/GHC/Tc/Utils/Monad.hs view
@@ -142,7 +142,7 @@ getCCIndexM, getCCIndexTcM, -- * Zonking- liftZonkM,+ liftZonkM, newZonkAnyType, -- * Types etc. module GHC.Tc.Types,@@ -153,6 +153,7 @@ import GHC.Builtin.Names+import GHC.Builtin.Types( zonkAnyTyCon ) import GHC.Tc.Errors.Types import GHC.Tc.Types -- Re-export all@@ -175,6 +176,7 @@ import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv+import GHC.Core.Type( mkNumLitTy ) import GHC.Driver.Env import GHC.Driver.Session@@ -254,6 +256,7 @@ infer_var <- newIORef True ; infer_reasons_var <- newIORef emptyMessages ; dfun_n_var <- newIORef emptyOccSet ;+ zany_n_var <- newIORef 0 ; let { type_env_var = hsc_type_env_vars hsc_env }; dependent_files_var <- newIORef [] ;@@ -345,6 +348,7 @@ tcg_patsyns = [], tcg_merged = [], tcg_dfun_n = dfun_n_var,+ tcg_zany_n = zany_n_var, tcg_keep = keep_var, tcg_hdr_info = (Nothing,Nothing), tcg_hpc = False,@@ -1801,6 +1805,18 @@ ; let occ = fn set ; writeTcRef dfun_n_var (extendOccSet set occ) ; return occ }++newZonkAnyType :: Kind -> TcM Type+-- Return a type (ZonkAny @k n), where n is fresh+-- Recall ZonkAny :: forall k. Natural -> k+-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)+newZonkAnyType kind+ = do { env <- getGblEnv+ ; let zany_n_var = tcg_zany_n env+ ; i <- readTcRef zany_n_var+ ; let !i2 = i+1+ ; writeTcRef zany_n_var i2+ ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) } getConstraintVar :: TcM (TcRef WantedConstraints) getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
compiler/GHC/Tc/Utils/Unify.hs view
@@ -348,9 +348,9 @@ The implication constraint will look like forall a b. (Eq a, Ord b) => <constraints> See the loop in GHC.Tc.Utils.Instantiate.topSkolemise.- This is just an optimisation; it would be fine to generate one implication- constraint for each nesting layer.+ and Note [Skolemisation en-bloc] in that module + Some examples: * f :: forall a b. blah@@ -775,29 +775,40 @@ ; return (mkWpCastN co, result) } matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside- = check 0 [] top_ty+ = check arity [] top_ty where check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a) -- `check` is called only in the Check{} case -- It collects rev_pat_tys in reversed order- -- n_so_far is the number of /visible/ arguments seen so far:- -- i.e. length (filterOut isExpForAllPatTyInvis rev_pat_tys)+ -- n_req is the number of /visible/ arguments still needed - -- Do shallow skolemisation if there are top-level invisible quantifiers- check n_so_far rev_pat_tys ty- | isSigmaTy ty -- Type has invisible quantifiers- = do { (wrap_gen, (wrap_res, result))- <- tcSkolemiseGeneral Shallow ctx top_ty ty $ \tv_bndrs ty' ->- let rev_pat_tys' = reverse (map (mkInvisExpPatType . snd) tv_bndrs)- ++ rev_pat_tys- in check n_so_far rev_pat_tys' ty'- ; return (wrap_gen <.> wrap_res, result) }+ ----------------------------+ -- Skolemise quantifiers, both visible (up to n_req) and invisible+ -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App+ check n_req rev_pat_tys ty+ | isSigmaTy ty -- An invisible quantifier at the top+ || (n_req > 0 && isForAllTy ty) -- A visible quantifier at top, and we need it+ = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty+ ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs)+ skol_tvs = binderVars bndrs+ ; skol_info <- mkSkolemInfo sig_skol }+ -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]+ -- in GHC.Tc.Utils.TcType+ ; (ev_binds, (wrap_res, result))+ <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $+ check n_req'+ (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys)+ inner_ty+ ; assertPpr (not (null bndrs && null given)) (ppr ty) $+ -- The guard ensures that we made some progress+ return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) } - -- (n_so_far == arity): no more args- -- rho_ty has no top-level quantifiers- -- If there is deep subsumption, do deep skolemisation- check n_so_far rev_pat_tys rho_ty- | n_so_far == arity+ ----------------------------+ -- Base case: (n_req == 0): no more args+ -- The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers+ -- If there is deep subsumption, do deep skolemisation now+ check n_req rev_pat_tys rho_ty+ | n_req == 0 = do { let pat_tys = reverse rev_pat_tys ; ds_flag <- getDeepSubsumptionFlag ; case ds_flag of@@ -808,53 +819,35 @@ -- They do not line up with binders in the Match thing_inside pat_tys (mkCheckExpType rho_ty) } - -- NOW do coreView. We didn't do it before, so that we do not unnecessarily- -- unwrap a synonym in the returned rho_ty- check n_so_far rev_pat_tys ty- | Just ty' <- coreView ty = check n_so_far rev_pat_tys ty'-- -- Decompose /visible/ (forall a -> blah), to give an ExpForAllPat- -- NB: invisible binders are handled by tcSplitSigmaTy/tcTopSkolemise above- -- NB: visible foralls "count" for the Arity argument; they correspond- -- to syntactically visible patterns in the source program- -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App- check n_so_far rev_pat_tys ty- | Just (Bndr tv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty- = assertPpr (isVisibleForAllTyFlag vis) (ppr ty) $- -- isSigmaTy case above has dealt with /invisible/ quantifiers,- -- so this one must be /visible/ (= Required)- do { let init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))- -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]- -- in GHC.Tc.Utils.TcType- ; rec { (subst', [tv']) <- tcInstSkolTyVarsX skol_info init_subst [tv]- ; let tv_prs = [(tyVarName tv, tv')]- ; skol_info <- mkSkolemInfo (SigSkol ctx top_ty tv_prs) }- ; let body_ty' = substTy subst' body_ty- pat_ty = ExpForAllPatTy (mkForAllTyBinder Required tv')- ; (ev_binds, (wrap_res, result)) <- checkConstraints (getSkolemInfo skol_info) [tv'] [] $- check (n_so_far+1) (pat_ty : rev_pat_tys) body_ty'- ; let wrap_gen = mkWpVisTyLam tv' body_ty' <.> mkWpLet ev_binds- ; return (wrap_gen <.> wrap_res, result) }-- check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult- , ft_arg = arg_ty, ft_res = res_ty })+ ----------------------------+ -- Function types+ check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult+ , ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $- do { let arg_pos = n_so_far + 1+ do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty- ; (wrap_res, result) <- check arg_pos+ ; (wrap_res, result) <- check (n_req - 1) (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys) res_ty ; let wrap_arg = mkWpCastN arg_co fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty ; return (fun_wrap, result) } - check n_so_far rev_pat_tys ty@(TyVarTy tv)+ ----------------------------+ -- Type variables+ check n_req rev_pat_tys ty@(TyVarTy tv) | isMetaTyVar tv = do { cts <- readMetaTyVar tv ; case cts of- Indirect ty' -> check n_so_far rev_pat_tys ty'- Flexi -> defer n_so_far rev_pat_tys ty }+ Indirect ty' -> check n_req rev_pat_tys ty'+ Flexi -> defer n_req rev_pat_tys ty } + ----------------------------+ -- NOW do coreView. We didn't do it before, so that we do not unnecessarily+ -- unwrap a synonym in the returned rho_ty+ check n_req rev_pat_tys ty+ | Just ty' <- coreView ty = check n_req rev_pat_tys ty'+ -- In all other cases we bale out into ordinary unification -- However unlike the meta-tyvar case, we are sure that the -- number of arguments doesn't match arity of the original@@ -870,14 +863,14 @@ -- -- But in that case we add specialized type into error context -- anyway, because it may be useful. See also #9605.- check n_so_far rev_pat_tys res_ty+ check n_req rev_pat_tys res_ty = addErrCtxtM (mkFunTysMsg herald (arity, top_ty)) $- defer n_so_far rev_pat_tys res_ty+ defer n_req rev_pat_tys res_ty ------------ defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a)- defer n_so_far rev_pat_tys fun_ty- = do { more_arg_tys <- mapM (new_check_arg_ty herald) [n_so_far + 1 .. arity]+ defer n_req rev_pat_tys fun_ty+ = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity] ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys ; res_ty <- newOpenFlexiTyVarTy ; result <- thing_inside all_pats (mkCheckExpType res_ty)@@ -892,7 +885,7 @@ ; return (mkScaled mult inf_hole) } new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)-new_check_arg_ty herald arg_pos -- Position for error messages only+new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) }@@ -2367,7 +2360,14 @@ do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs -- Attempt to unify kinds- ; co_k <- uType (mkKindEnv env ty1 ty2) (typeKind ty2) (tyVarKind tv1)+ -- When doing so, be careful to preserve orientation;+ -- see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality+ -- and wrinkle (W2) in Note [Fundeps with instances, and equality orientation]+ -- in GHC.Tc.Solver.Dict+ -- Failing to preserve orientation led to #25597.+ ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2+ ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2)+ ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) , ppr ty2 <+> dcolon <+> ppr (typeKind ty2)
compiler/GHC/Tc/Zonk/Type.hs view
@@ -54,7 +54,7 @@ import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Monad ( setSrcSpanA, liftZonkM, traceTc, addErr )+import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types@@ -468,8 +468,9 @@ -> do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) ; return (anyTypeOfKind zonked_kind) } | otherwise- -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)- ; return (anyTypeOfKind zonked_kind) }+ -> do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)+ -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)+ ; newZonkAnyType zonked_kind } RuntimeUnkFlexi -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
compiler/GHC/ThToHs.hs view
@@ -1485,7 +1485,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'} cvtp (TypeP t) = do { t' <- cvtType t
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.10.1.20250421+version: 9.10.2.20250503 license: BSD-3-Clause license-file: LICENSE category: Development@@ -104,7 +104,7 @@ semaphore-compat, rts, hpc >= 0.6 && < 0.8,- ghc-lib-parser == 9.10.1.20250421+ ghc-lib-parser == 9.10.2.20250503 build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2 other-extensions: BangPatterns@@ -239,6 +239,7 @@ GHC.Data.FastString, GHC.Data.FastString.Env, GHC.Data.FiniteMap,+ GHC.Data.FlatBag, GHC.Data.Graph.Directed, GHC.Data.Graph.UnVar, GHC.Data.IOEnv,@@ -419,7 +420,7 @@ GHC.Types.Annotations, GHC.Types.Avail, GHC.Types.Basic,- GHC.Types.BreakInfo,+ GHC.Types.Breakpoint, GHC.Types.CompleteMatch, GHC.Types.CostCentre, GHC.Types.CostCentre.State,@@ -530,7 +531,6 @@ GHC.Utils.Trace, GHC.Utils.Word64, GHC.Version,- GHCi.BinaryArray, GHCi.BreakArray, GHCi.FFI, GHCi.Message,
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -11,7 +11,7 @@ primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv +primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv primOpStrictness Control0Op = \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv primOpStrictness AtomicallyOp = \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv primOpStrictness RetryOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv
ghc-lib/stage0/lib/settings view
@@ -8,6 +8,11 @@ ,("CPP flags", "-E") ,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")+,("JavaScript CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("JavaScript CPP flags", "-E -CC -Wno-unicode -nostdinc")+,("C-- CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("C-- CPP flags", "-E")+,("C-- CPP supports -g0", "YES") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES") ,("ld supports single module", "NO")