diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -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 diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -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) _) diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -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 "" - <+> ppr index <+> text "" <+> text "" + ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _) + = text "BRK_FUN" <+> text "" + <+> text "" <+> ppr tickx + <+> text "" <+> ppr infox + <+> text "" diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -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 diff --git a/compiler/GHC/Cmm/Dominators.hs b/compiler/GHC/Cmm/Dominators.hs --- a/compiler/GHC/Cmm/Dominators.hs +++ b/compiler/GHC/Cmm/Dominators.hs @@ -23,7 +23,6 @@ import GHC.Prelude import Data.Array.IArray -import Data.Foldable() import qualified Data.Tree as Tree import Data.Word diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -213,23 +213,33 @@ = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can +-- Make a RegOff if we can. We don't perform this optimization if rep is greater +-- than the host word size because we use an Int to store the offset. See +-- #24893 and #24700. This should be fixed to ensure that optimizations don't +-- depend on the compiler host platform. cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) @@ -409,6 +419,13 @@ -- Anything else is just too hard. cmmMachOpFoldM _ _ _ = Nothing + +-- | Check that a literal width is compatible with the host word size used to +-- store offsets. This should be fixed properly (using larger types to store +-- literal offsets). See #24893 +validOffsetRep :: Width -> Bool +validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) + {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs --- a/compiler/GHC/Cmm/ThreadSanitizer.hs +++ b/compiler/GHC/Cmm/ThreadSanitizer.hs @@ -184,7 +184,7 @@ restore = blockFromList restore_nodes -- | Mirrors __tsan_memory_order --- +-- 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' - diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs --- a/compiler/GHC/CmmToAsm/AArch64.hs +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -47,6 +47,7 @@ patchRegsOfInstr = AArch64.patchRegsOfInstr isJumpishInstr = AArch64.isJumpishInstr jumpDestsOfInstr = AArch64.jumpDestsOfInstr + canFallthroughTo = AArch64.canFallthroughTo patchJumpInstr = AArch64.patchJumpInstr mkSpillInstr = AArch64.mkSpillInstr mkLoadInstr = AArch64.mkLoadInstr diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -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) diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -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. -- 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" diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs --- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -17,6 +17,7 @@ import GHC.Utils.Panic import GHC.Platform +-- TODO: Should this include the zero register? allMachRegNos :: [RegNo] allMachRegNos = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed. diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -71,10 +71,16 @@ :: instr -> Bool - -- | Give the possible destinations of this jump instruction. + -- | Give the possible *local block* destinations of this jump instruction. -- Must be defined for all jumpish instructions. jumpDestsOfInstr :: instr -> [BlockId] + + -- | Check if the instr always transfers control flow + -- to the given block. Used by code layout to eliminate + -- jumps that can be replaced by fall through. + canFallthroughTo + :: instr -> BlockId -> Bool -- | Change the destination of this jump instruction. diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -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; \@ -- when possible. } + +{- Note [supporting shortcutting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the concept of shortcutting see Note [What is shortcutting]. + +In order to support shortcutting across multiple backends uniformly we +use canShortcut, shortcutStatics and shortcutJump. + +canShortcut tells us if the backend support shortcutting of a instruction +and if so what destination we should retarget instruction to instead. + +shortcutStatics exists to allow us to update jump destinations in jump tables. + +shortcutJump updates the instructions itself. + +A backend can opt out of those by always returning Nothing for canShortcut +and implementing shortcutStatics/shortcutJump as \_ x -> x + +-} {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs --- a/compiler/GHC/CmmToAsm/PPC.hs +++ b/compiler/GHC/CmmToAsm/PPC.hs @@ -46,6 +46,7 @@ patchRegsOfInstr = PPC.patchRegsOfInstr isJumpishInstr = PPC.isJumpishInstr jumpDestsOfInstr = PPC.jumpDestsOfInstr + canFallthroughTo = PPC.canFallthroughTo patchJumpInstr = PPC.patchJumpInstr mkSpillInstr = PPC.mkSpillInstr mkLoadInstr = PPC.mkLoadInstr diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -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) diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -22,6 +22,7 @@ , patchJumpInstr , patchRegsOfInstr , jumpDestsOfInstr + , canFallthroughTo , takeRegRegMoveInstr , takeDeltaInstr , mkRegRegMoveInstr @@ -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. diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs --- a/compiler/GHC/CmmToAsm/X86.hs +++ b/compiler/GHC/CmmToAsm/X86.hs @@ -51,6 +51,7 @@ patchRegsOfInstr = X86.patchRegsOfInstr isJumpishInstr = X86.isJumpishInstr jumpDestsOfInstr = X86.jumpDestsOfInstr + canFallthroughTo = X86.canFallthroughTo patchJumpInstr = X86.patchJumpInstr mkSpillInstr = X86.mkSpillInstr mkLoadInstr = X86.mkLoadInstr diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -31,6 +31,7 @@ , mkSpillInstr , mkRegRegMoveInstr , jumpDestsOfInstr + , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr @@ -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 diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -11,7 +11,7 @@ ) where -import GHC.Prelude hiding ( head ) +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -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 diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs --- a/compiler/GHC/Core/LateCC.hs +++ b/compiler/GHC/Core/LateCC.hs @@ -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 -> diff --git a/compiler/GHC/Core/LateCC/TopLevelBinds.hs b/compiler/GHC/Core/LateCC/TopLevelBinds.hs --- a/compiler/GHC/Core/LateCC/TopLevelBinds.hs +++ b/compiler/GHC/Core/LateCC/TopLevelBinds.hs @@ -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 = 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 -> + 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 diff --git a/compiler/GHC/Core/LateCC/Types.hs b/compiler/GHC/Core/LateCC/Types.hs --- a/compiler/GHC/Core/LateCC/Types.hs +++ b/compiler/GHC/Core/LateCC/Types.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -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: diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -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. -} diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -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 diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -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 in rhs where 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) diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs --- a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -80,6 +80,7 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") { -- Don't do case-of-case transformations. -- This makes full laziness work better + -- See Note [Case-of-case and full laziness] sm_case_case = False } @@ -89,3 +90,37 @@ (True, True) -> FloatEnabled (True, False)-> FloatNestedOnly (False, _) -> FloatDisabled + + +{- Note [Case-of-case and full laziness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case-of-case can hide opportunities for let-floating (full laziness). +For example + rec { f = \y. case (expensive x) of (a,b) -> blah } +We might hope to float the (expensive x) out of the \y-loop. +But if we inline `expensive` we might get + \y. case (case x of I# x' -> body) of (a,b) -> blah +Now if we do case-of-case we get + \y. case x if I# x2 -> + case body of (a,b) -> blah + +Sadly, at this point `body` mentions `x2`, so we can't float it out of the +\y-loop. + +Solution: don't do case-of-case in the "gentle" simplification phase that +precedes the first float-out transformation. Implementation: + + * `sm_case_case` field in SimplMode + + * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case + in GHC.Core.Opt.Simplify.Iteration.rebuildCall. + +Wrinkles + +* This applies equally to the case-of-runRW# transformation: + case (runRW# (\s. body)) of (a,b) -> blah + ---> + runRW# (\s. case body of (a,b) -> blah) + Again, don't do this when `sm_case_case` is off. See #25055 for + a motivating example. +-} diff --git a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs --- a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs +++ b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs @@ -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 diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -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 diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -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 diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -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) $ diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -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 ] diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -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 diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -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 diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -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 diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -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 diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -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 diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -172,6 +172,6 @@ findLoadDLL (p:ps) errs = do { dll <- loadDLL interp (p fwk_file) ; case dll of - Nothing -> return Nothing - Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) + Right _ -> return Nothing + Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) } diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -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 diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -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. diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -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 diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -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 diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -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 "") + 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 "") + -- 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 diff --git a/compiler/GHC/Runtime/Interpreter/JS.hs b/compiler/GHC/Runtime/Interpreter/JS.hs --- a/compiler/GHC/Runtime/Interpreter/JS.hs +++ b/compiler/GHC/Runtime/Interpreter/JS.hs @@ -41,7 +41,6 @@ import GHC.Utils.Error (logInfo) import GHC.Utils.Outputable (text) import GHC.Data.FastString -import GHC.Types.Unique.FM import Control.Concurrent import Control.Monad @@ -178,11 +177,9 @@ } pending_frees <- newMVar [] - lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = proc , instPendingFrees = pending_frees - , instLookupSymbolCache = lookup_cache , instExtra = extra } diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -16,9 +16,11 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic +import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map @@ -72,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 diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -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) diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs --- a/compiler/GHC/StgToCmm/InfoTableProv.hs +++ b/compiler/GHC/StgToCmm/InfoTableProv.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs --- a/compiler/GHC/StgToJS/Linker/Linker.hs +++ b/compiler/GHC/StgToJS/Linker/Linker.hs @@ -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} */ 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 diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs --- a/compiler/GHC/StgToJS/Linker/Utils.hs +++ b/compiler/GHC/StgToJS/Linker/Utils.hs @@ -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" diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs --- a/compiler/GHC/StgToJS/Literal.hs +++ b/compiler/GHC/StgToJS/Literal.hs @@ -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 diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs --- a/compiler/GHC/StgToJS/Prim.hs +++ b/compiler/GHC/StgToJS/Prim.hs @@ -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 ------------------------- diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs --- a/compiler/GHC/StgToJS/Rts/Rts.hs +++ b/compiler/GHC/StgToJS/Rts/Rts.hs @@ -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 $ diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs --- a/compiler/GHC/SysTools/Cpp.hs +++ b/compiler/GHC/SysTools/Cpp.hs @@ -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 diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -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 + LLVM version 15.0.7 ... + OR + LLVM (http://llvm.org/): + LLVM version 14.0.6 -} hSetBinaryMode pout False - _ <- hGetLine pout - vline <- hGetLine pout - let mb_ver = parseLlvmVersion vline + line1 <- hGetLine pout + mb_ver <- case parseLlvmVersion line1 of + mb_ver@(Just _) -> return mb_ver + Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line hClose pin hClose pout hClose perr diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -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`. -} ----------------------- diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -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] diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -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] diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -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 diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -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 diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -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. diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs --- a/compiler/GHC/Tc/Solver/Equality.hs +++ b/compiler/GHC/Tc/Solver/Equality.hs @@ -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, ) + [W] F (alpha, beta) ~ (Int, ) 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 ] } diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -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: diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -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). 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). a d1 b d2 + where + wp = /\a. \(d:Ord a). 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). 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) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -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) } diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -348,9 +348,9 @@ The implication constraint will look like forall a b. (Eq a, Ord b) => 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) diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs --- a/compiler/GHC/Tc/Zonk/Type.hs +++ b/compiler/GHC/Tc/Zonk/Type.hs @@ -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) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib -version: 9.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, diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -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 diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -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")