diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -57,7 +57,7 @@ SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, + parseModule, typecheckModule, desugarModule, ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), TypecheckedSource, ParsedSource, RenamedSource, -- ditto TypecheckedMod, ParsedMod, @@ -310,11 +310,12 @@ import GHC.Driver.CmdLine import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks -import GHC.Driver.Pipeline ( compileOne' ) import GHC.Driver.Monad import GHC.Driver.Ppr @@ -357,6 +358,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Utils.Fingerprint import GHC.Core.Predicate import GHC.Core.Type hiding( typeKind ) @@ -387,12 +389,10 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv -import GHC.Types.SourceFile import GHC.Unit import GHC.Unit.Env import GHC.Unit.External -import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts @@ -407,7 +407,6 @@ import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe -import Data.Time import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import Control.Monad @@ -446,19 +445,18 @@ case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> - fatalErrorMsg'' fm (show ioe) + fm (show ioe) _ -> case fromException exception of Just UserInterrupt -> -- Important to let this one propagate out so our -- calling process knows we were interrupted by ^C liftIO $ throwIO UserInterrupt Just StackOverflow -> - fatalErrorMsg'' fm "stack overflow: use +RTS -K to increase it" + fm "stack overflow: use +RTS -K to increase it" _ -> case fromException exception of Just (ex :: ExitCode) -> liftIO $ throwIO ex _ -> - fatalErrorMsg'' fm - (show (Panic (show exception))) + fm (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ @@ -468,7 +466,7 @@ flushOut case ge of Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg'' fm (show ge) + _ -> do fm (show ge) exitWith (ExitFailure 1) ) $ inner @@ -657,7 +655,7 @@ | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 - then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg) + then return (logInfo logger $ withPprStyle defaultDumpStyle msg) else return (pure ()) let conf = IServConfig @@ -689,13 +687,15 @@ , ue_units = unit_state , ue_unit_dbs = Just dbs } - modifySession $ \h -> h{ hsc_dflags = dflags - , hsc_IC = (hsc_IC h){ ic_dflags = dflags } + + modifySession $ \h -> hscSetFlags dflags $ + h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } , hsc_interp = hsc_interp h <|> interp -- we only update the interpreter if there wasn't -- already one set up , hsc_unit_env = unit_env } + invalidateModSummaryCache -- | Sets the program 'DynFlags'. Note: this invalidates the internal @@ -730,10 +730,9 @@ , ue_units = unit_state , ue_unit_dbs = Just dbs } - modifySession $ \h -> h{ hsc_dflags = dflags1 - , hsc_unit_env = unit_env - } - else modifySession $ \h -> h{ hsc_dflags = dflags0 } + modifySession $ \h -> hscSetFlags dflags1 $ h{ hsc_unit_env = unit_env } + else modifySession (hscSetFlags dflags0) + when invalidate_needed $ invalidateModSummaryCache return changed @@ -750,7 +749,7 @@ -- old log_action. This is definitely wrong (#7478). -- -- Hence, we invalidate the ModSummary cache after changing the --- DynFlags. We do this by tweaking the date on each ModSummary, so +-- DynFlags. We do this by tweaking the hash on each ModSummary, so -- that the next downsweep will think that all the files have changed -- and preprocess them again. This won't necessarily cause everything -- to be recompiled, because by the time we check whether we need to @@ -761,7 +760,7 @@ invalidateModSummaryCache = modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } where - inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } + inval ms = ms { ms_hs_hash = fingerprint0 } -- | Returns the program 'DynFlags'. getProgramDynFlags :: GhcMonad m => m DynFlags @@ -783,7 +782,7 @@ -- Initialise (load) plugins in the interactive environment with the new -- DynFlags - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + plugin_env <- liftIO $ flip initializePlugins Nothing $ mkInteractiveHscEnv $ hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} -- Update both plugins cache and DynFlags in the interactive context. @@ -808,7 +807,10 @@ -> m (DynFlags, [Located String], [Warn]) parseDynamicFlags logger dflags cmdline = do (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline - dflags2 <- liftIO $ interpretPackageEnv logger dflags1 + -- flags that have just been read are used by the logger when loading package + -- env (this is checked by T16318) + let logger1 = setLogFlags logger (initLogFlags dflags1) + dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 return (dflags2, leftovers, warns) -- | Parse command line arguments that look like files. @@ -901,7 +903,8 @@ checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings logger dflags (map (Warn WarningWithoutFlag) warnings) + let diag_opts = initDiagOpts dflags + liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings) return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags @@ -909,10 +912,12 @@ -- We currently don't support use of StaticPointers in expressions entered on -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowDiagnostics logger dflags0 $ singleMessage - $ fmap GhcDriverMessage - $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan DriverStaticPointersNotSupported - return $ xopt_unset dflags0 LangExt.StaticPointers + then do + let diag_opts = initDiagOpts dflags0 + liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage + $ fmap GhcDriverMessage + $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported + return $ xopt_unset dflags0 LangExt.StaticPointers else return dflags0 @@ -1134,9 +1139,10 @@ parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) + liftIO $ do + let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env + hpm <- hscParse lcl_hsc_env ms + return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) -- See Note [exact print annotations] in GHC.Parser.Annotation -- | Typecheck and rename a parsed module. @@ -1144,17 +1150,20 @@ -- Throws a 'SourceError' if either fails. typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do - let ms = modSummary pmod hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod } - details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env - safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - return $ + liftIO $ do + let ms = modSummary pmod + let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.) + let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env + let lcl_logger = hsc_logger lcl_hsc_env + (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod } + details <- makeSimpleDetails lcl_logger tc_gbl_env + safe <- finalSafeMode lcl_dflags tc_gbl_env + + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), tm_parsed_module = pmod, @@ -1174,54 +1183,20 @@ -- | Desugar a typechecked module. desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do - let ms = modSummary tcm - let (tcg, _) = tm_internals tcm hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg - return $ + liftIO $ do + let ms = modSummary tcm + let (tcg, _) = tm_internals tcm + let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env + guts <- hscDesugar lcl_hsc_env ms tcg + return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts } --- | Load a module. Input doesn't need to be desugared. --- --- A module must be loaded before dependent modules can be typechecked. This --- always includes generating a 'ModIface' and, depending on the --- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation. --- --- This function will always cause recompilation and will always overwrite --- previous compilation results (potentially files on disk). --- -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - let loc = ms_location ms - let (tcg, _details) = tm_internals tcm - mb_linkable <- case ms_obj_date ms of - Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) - (ml_obj_file loc) t - return (Just l) - _otherwise -> return Nothing - let source_modified | isNothing mb_linkable = SourceModified - | otherwise = SourceUnmodified - -- we can't determine stability here - - -- compile doesn't change the session - hsc_env <- getSession - mod_info <- liftIO $ compileOne' (Just tcg) Nothing - hsc_env ms 1 1 Nothing mb_linkable - source_modified - - modifySession $ hscUpdateHPT (\hpt -> addToHpt hpt mod mod_info) - return tcm - - -- %************************************************************************ -- %* * -- Dealing with Core @@ -1862,7 +1837,7 @@ return dflags Just envfile -> do content <- readFile envfile - compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile) + compilationProgressMsg logger (text "Loaded package environment from " <> text envfile) let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags return dflags' diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -78,6 +78,8 @@ import GHC.Hs.Doc import GHC.Unit.Module.ModIface (IfaceExport) +import GHC.Data.List.SetOps + import Control.Applicative ((<|>)) import Data.List ( intercalate , find ) import Data.Array 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 @@ -28,6 +28,7 @@ import GHCi.BreakArray import GHC.Builtin.PrimOps +import GHC.Builtin.Names import GHC.Unit.Types import GHC.Unit.Module.Name @@ -184,7 +185,11 @@ nameToCLabel n suffix = mkFastString label where encodeZ = zString . zEncodeFS - (Module pkgKey modName) = assert (isExternalName n) $ nameModule n + (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of + -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers + -- See Note [Primop wrappers] in GHC.Builtin.PrimOps. + mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS + mod -> mod packagePart = encodeZ (unitFS pkgKey) modulePart = encodeZ (moduleNameFS modName) occPart = encodeZ (occNameFS (nameOccName n)) diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -46,7 +46,6 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Data.Maybe -import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -67,20 +66,19 @@ , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a +cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) -cmmToRawCmm logger dflags cmms +cmmToRawCmm logger profile cmms = do { ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl] do_one cmm = do uniqs <- mkSplitUniqSupply 'i' -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTimingSilent logger dflags (text "Cmm -> Raw Cmm") - (\x -> seqList x ()) + withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) -- TODO: It might be better to make `mkInfoTable` run in -- IO as well so we don't have to pass around -- a UniqSupply (see #16843) - (return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm) + (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm) ; return (Stream.mapM do_one cmms) } @@ -118,15 +116,15 @@ -- -- * The SRT slot is only there if there is SRT info to record -mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl] +mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) +mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks) -- -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. -- - | not (platformTablesNextToCode (targetPlatform dflags)) + | not (platformTablesNextToCode platform) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> @@ -134,7 +132,7 @@ Just info@CmmInfoTable { cit_lbl = info_lbl } -> do (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags info Nothing + mkInfoTableContents profile info Nothing let rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits @@ -161,10 +159,10 @@ [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where - platform = targetPlatform dflags + platform = profilePlatform profile do_one_info (lbl,itbl) = do (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags itbl Nothing + mkInfoTableContents profile itbl Nothing let info_lbl = cit_lbl itbl rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info @@ -178,20 +176,20 @@ , [CmmLit] ) -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them -mkInfoTableContents :: DynFlags +mkInfoTableContents :: Profile -> CmmInfoTable -> Maybe Int -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls InfoTableContents) -- Info tbl + extra bits -mkInfoTableContents dflags +mkInfoTableContents profile info@(CmmInfoTable { cit_lbl = info_lbl , cit_rep = smrep , cit_prof = prof , cit_srt = srt }) mb_rts_tag | RTSRep rts_tag rep <- smrep - = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) + = mkInfoTableContents profile info{cit_rep = rep} (Just rts_tag) -- Completely override the rts_tag that mkInfoTableContents would -- otherwise compute, with the rts_tag stored in the RTSRep -- (which in turn came from a handwritten .cmm file) @@ -199,9 +197,9 @@ | StackRep frame <- smrep = do { (prof_lits, prof_data) <- mkProfLits platform prof ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt - ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame + ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame ; let - std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit + std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag | null liveness_data = rET_SMALL -- Fits in extra_bits | otherwise = rET_BIG -- Does not; extra_bits is @@ -214,13 +212,13 @@ ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label - ; let std_info = mkStdInfoTable dflags prof_lits + ; let std_info = mkStdInfoTable profile prof_lits (mb_rts_tag `orElse` rtsClosureType smrep) (mb_srt_field `orElse` srt_bitmap) (mb_layout `orElse` layout) ; return (prof_data ++ ct_data, (std_info, extra_bits)) } where - platform = targetPlatform dflags + platform = profilePlatform profile mk_pieces :: ClosureTypeInfo -> [CmmLit] -> UniqSM ( Maybe CmmLit -- Override the SRT field with this , Maybe CmmLit -- Override the layout field with this @@ -245,7 +243,7 @@ ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label - = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits + = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG extra_bits = [ packIntsCLit platform fun_type arity ] @@ -343,12 +341,12 @@ -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) +mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) -- ^ Returns: -- 1. The bitmap (literal value or label) -- 2. Large bitmap CmmData if needed -mkLivenessBits dflags liveness +mkLivenessBits platform liveness | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word = do { uniq <- getUniqueM ; let bitmap_lbl = mkBitmapLabel uniq @@ -358,7 +356,6 @@ | otherwise -- Fits in one word = return (mkStgWordCLit platform bitmap_word, []) where - platform = targetPlatform dflags n_bits = length liveness bitmap :: Bitmap @@ -390,14 +387,14 @@ -- so we can't use constant offsets from Constants mkStdInfoTable - :: DynFlags + :: Profile -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> Int -- Closure RTS tag -> CmmLit -- SRT length -> CmmLit -- layout field -> [CmmLit] -mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit +mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit = -- Parallel revertible-black hole field prof_info -- Ticky info (none at present) @@ -405,9 +402,9 @@ ++ [layout_lit, tag, srt] where - platform = targetPlatform dflags + platform = profilePlatform profile prof_info - | sccProfilingEnabled dflags = [type_descr, closure_descr] + | profileIsProfiling profile = [type_descr, closure_descr] | otherwise = [] tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform) diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -41,7 +41,7 @@ import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap -import GHC.CmmToAsm +import GHC.Driver.Config.CmmToAsm import Control.Monad import Data.Map.Strict (Map) diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -205,6 +205,10 @@ import GHC.Prelude import qualified Prelude -- for happy-generated code +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Config.Parser (initParserOpts) + import GHC.Platform import GHC.Platform.Profile @@ -251,9 +255,6 @@ import GHC.Types.Unique.FM import GHC.Types.SrcLoc import GHC.Types.Tickish ( GenTickish(SourceNote) ) -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Utils.Error import GHC.Data.StringBuffer import GHC.Data.FastString @@ -1021,6 +1022,45 @@ callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps platform = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ + + ( "pow64f", (MO_F64_Pwr,) ), + ( "sin64f", (MO_F64_Sin,) ), + ( "cos64f", (MO_F64_Cos,) ), + ( "tan64f", (MO_F64_Tan,) ), + ( "sinh64f", (MO_F64_Sinh,) ), + ( "cosh64f", (MO_F64_Cosh,) ), + ( "tanh64f", (MO_F64_Tanh,) ), + ( "asin64f", (MO_F64_Asin,) ), + ( "acos64f", (MO_F64_Acos,) ), + ( "atan64f", (MO_F64_Atan,) ), + ( "asinh64f", (MO_F64_Asinh,) ), + ( "acosh64f", (MO_F64_Acosh,) ), + ( "log64f", (MO_F64_Log,) ), + ( "log1p64f", (MO_F64_Log1P,) ), + ( "exp64f", (MO_F64_Exp,) ), + ( "expM164f", (MO_F64_ExpM1,) ), + ( "fabs64f", (MO_F64_Fabs,) ), + ( "sqrt64f", (MO_F64_Sqrt,) ), + + ( "pow32f", (MO_F32_Pwr,) ), + ( "sin32f", (MO_F32_Sin,) ), + ( "cos32f", (MO_F32_Cos,) ), + ( "tan32f", (MO_F32_Tan,) ), + ( "sinh32f", (MO_F32_Sinh,) ), + ( "cosh32f", (MO_F32_Cosh,) ), + ( "tanh32f", (MO_F32_Tanh,) ), + ( "asin32f", (MO_F32_Asin,) ), + ( "acos32f", (MO_F32_Acos,) ), + ( "atan32f", (MO_F32_Atan,) ), + ( "asinh32f", (MO_F32_Asinh,) ), + ( "acosh32f", (MO_F32_Acosh,) ), + ( "log32f", (MO_F32_Log,) ), + ( "log1p32f", (MO_F32_Log1P,) ), + ( "exp32f", (MO_F32_Exp,) ), + ( "expM132f", (MO_F32_ExpM1,) ), + ( "fabs32f", (MO_F32_Fabs,) ), + ( "sqrt32f", (MO_F32_Sqrt,) ), + ( "read_barrier", (MO_ReadBarrier,)), ( "write_barrier", (MO_WriteBarrier,)), ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), @@ -1060,10 +1100,6 @@ ( "xchg16", (MO_Xchg W16,)), ( "xchg32", (MO_Xchg W32,)), ( "xchg64", (MO_Xchg W64,)) - - -- ToDo: the rest, maybe - -- edit: which rest? - -- also: how do we tell CMM Lint how to type check callish macops? ] where memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -46,20 +46,20 @@ let logger = hsc_logger hsc_env let dflags = hsc_dflags hsc_env let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group - withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do - tops <- {-# SCC "tops" #-} mapM (cpsTop logger dflags) prog + let platform = targetPlatform dflags + withTimingSilent logger (text "Cmm pipeline") forceRes $ do + tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform dflags) prog let (procs, data_) = partitionEithers tops (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ - let platform = targetPlatform dflags - dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) + dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) -cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) -cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) -cpsTop logger dflags proc = +cpsTop :: Logger -> Platform -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p)) +cpsTop logger platform dflags proc = do ----------- Control-flow optimisations ---------------------------------- @@ -96,7 +96,7 @@ then do pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ minimalProcPointSet platform call_pps g - dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points" + dumpWith logger Opt_D_dump_cmm_proc "Proc points" FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) return pp else @@ -117,14 +117,14 @@ ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g - dumpWith logger dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) + dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) g <- if splitting_proc_points then do ------------- Split into separate procedures ----------------------- let pp_map = {-# SCC "procPointAnalysis" #-} procPointAnalysis proc_points g - dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map" + dumpWith logger Opt_D_dump_cmm_procmap "procpoint map" FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints platform l call_pps proc_points pp_map @@ -151,11 +151,10 @@ return (Left (cafEnv, g)) - where platform = targetPlatform dflags - dump = dumpGraph logger dflags + where dump = dumpGraph logger platform dflags dumps flag name - = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform) + = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) condPass flag pass g dumpflag dumpname = if gopt flag dflags @@ -348,24 +347,23 @@ return (initUs_ us m) -dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph logger dflags flag name g = do +dumpGraph :: Logger -> Platform -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger platform dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith logger dflags flag name FormatCMM (pdoc platform g) + dumpWith logger flag name FormatCMM (pdoc platform g) where - platform = targetPlatform dflags do_lint g = case cmmLintGraph platform g of - Just err -> do { fatalErrorMsg logger dflags err - ; ghcExit logger dflags 1 + Just err -> do { fatalErrorMsg logger err + ; ghcExit logger 1 } Nothing -> return () -dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpWith logger dflags flag txt fmt sdoc = do - dumpIfSet_dyn logger dflags flag txt fmt sdoc - when (not (dopt flag dflags)) $ +dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpWith logger flag txt fmt sdoc = do + putDumpFileMaybe logger flag txt fmt sdoc + when (not (logHasDumpFlag logger flag)) $ -- If `-ddump-cmm-verbose -ddump-to-file` is specified, -- dump each Cmm pipeline stage output to a separate file. #16930 - when (dopt Opt_D_dump_cmm_verbose dflags) - $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc + when (logHasDumpFlag logger Opt_D_dump_cmm_verbose) + $ logDumpFile logger (mkDumpStyle alwaysQualify) flag txt fmt sdoc + putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs --- a/compiler/GHC/Cmm/Ppr/Expr.hs +++ b/compiler/GHC/Cmm/Ppr/Expr.hs @@ -44,12 +44,11 @@ import GHC.Prelude -import GHC.Driver.Ppr - import GHC.Platform import GHC.Cmm.Expr import GHC.Utils.Outputable +import GHC.Utils.Trace import Data.Maybe import Numeric ( fromRat ) diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -14,7 +14,7 @@ module GHC.Cmm.Utils( -- CmmType - primRepCmmType, slotCmmType, slotForeignHint, + primRepCmmType, slotCmmType, typeCmmType, typeForeignHint, primRepForeignHint, -- CmmLit @@ -158,14 +158,6 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint - -slotForeignHint :: SlotTy -> ForeignHint -slotForeignHint PtrLiftedSlot = AddrHint -slotForeignHint PtrUnliftedSlot = AddrHint -slotForeignHint WordSlot = NoHint -slotForeignHint Word64Slot = NoHint -slotForeignHint FloatSlot = NoHint -slotForeignHint DoubleSlot = NoHint typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep1 diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -75,7 +75,6 @@ -- cmmNativeGen emits , cmmNativeGen , NcgImpl(..) - , initNCGConfig ) where @@ -84,6 +83,7 @@ import qualified GHC.CmmToAsm.X86 as X86 import qualified GHC.CmmToAsm.PPC as PPC import qualified GHC.CmmToAsm.SPARC as SPARC +import qualified GHC.CmmToAsm.AArch64 as AArch64 import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear as Linear @@ -148,15 +148,14 @@ import System.IO -------------------- -nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply +nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen logger dflags this_mod modLoc h us cmms - = let config = initNCGConfig dflags this_mod - platform = ncgPlatform config +nativeCodeGen logger config modLoc h us cmms + = let platform = ncgPlatform config nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a - nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms + nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (X86.ncgX86 config) ArchX86_64 -> nCG' (X86.ncgX86_64 config) @@ -166,7 +165,7 @@ ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" ArchS390X -> panic "nativeCodeGen: No NCG for S390X" ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" - ArchAArch64 -> panic "nativeCodeGen: No NCG for AArch64" + ArchAArch64 -> nCG' (AArch64.ncgAArch64 config) ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" @@ -174,7 +173,6 @@ ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" - -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation. data NativeGenAcc statics instr @@ -221,7 +219,6 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger - -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -229,35 +226,34 @@ -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms +nativeCodeGen' logger config modLoc ncgImpl h us cmms = do -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty - (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us + (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us cmms ngs0 - _ <- finishNativeGen logger dflags config modLoc bufh us' ngs + _ <- finishNativeGen logger config modLoc bufh us' ngs return a finishNativeGen :: Instruction instr => Logger - -> DynFlags -> NCGConfig -> ModLocation -> BufHandle -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply -finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs - = withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do +finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs + = withTimingSilent logger (text "NCG") (`seq` ()) $ do -- Write debug data and finish us' <- if not (ncgDwarfEnabled config) then return us else do (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs) - emitNativeCode logger dflags config bufh dwarf + emitNativeCode logger config bufh dwarf return us' bFlush bufh @@ -274,7 +270,7 @@ dump_stats (Color.pprStats stats graphGlobal) let platform = ncgPlatform config - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_conflicts "Register conflict graph" FormatText $ Color.dotGraph @@ -296,13 +292,12 @@ $ makeImportsDoc config (concat (ngs_imports ngs)) return us' where - dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify) + dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify) Opt_D_dump_asm_stats "NCG stats" FormatText cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger - -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -312,7 +307,7 @@ -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs +cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs = loop us (Stream.runStream cmm_stream) ngs where ncglabel = text "NCG" @@ -334,7 +329,6 @@ Stream.Yield cmms cmm_stream' -> do (us', ngs'') <- withTimingSilent logger - dflags ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms @@ -342,15 +336,15 @@ dbgMap = debugToMap ndbgs -- Generate native code - (ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h + (ngs',us') <- cmmNativeGens logger config modLoc ncgImpl h dbgMap us cmms ngs 0 -- Link native code information into debug blocks -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs - platform = targetPlatform dflags + platform = ncgPlatform config unless (null ldbgs) $ - dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText + putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText (vcat $ map (pdoc platform) ldbgs) -- Accumulate debug information for emission in finishNativeGen. @@ -365,7 +359,6 @@ cmmNativeGens :: forall statics instr jumpDest. (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger - -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -377,7 +370,7 @@ -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go +cmmNativeGens logger config modLoc ncgImpl h dbgMap = go where go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int @@ -390,7 +383,7 @@ let fileIds = ngs_dwarfFiles ngs (us', fileIds', native, imports, colorStats, linearStats, unwinds) <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap + cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count -- Generate .file directives for every new file that has been @@ -402,17 +395,17 @@ pprDecl (f,n) = text "\t.file " <> ppr n <+> pprFilePathString (unpackFS f) - emitNativeCode logger dflags config h $ vcat $ + emitNativeCode logger config h $ vcat $ map pprDecl newFileIds ++ map (pprNatCmmDecl ncgImpl) native -- force evaluation all this stuff to avoid space leaks - let platform = targetPlatform dflags - {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) () + let platform = ncgPlatform config + {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) () let !labels' = if ncgDwarfEnabled config then cmmDebugLabels isMetaInstr native else [] - !natives' = if dopt Opt_D_dump_asm_stats dflags + !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats then native : ngs_natives ngs else [] mCon = maybe id (:) @@ -427,14 +420,14 @@ go us' cmms ngs' (count + 1) -emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO () -emitNativeCode logger dflags config h sdoc = do +emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO () +emitNativeCode logger config h sdoc = do let ctx = ncgAsmContext config {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm "Asm code" FormatASM sdoc @@ -444,7 +437,6 @@ cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) => Logger - -> DynFlags -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply @@ -461,7 +453,7 @@ , LabelMap [UnwindPoint] -- unwinding information for blocks ) -cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count +cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count = do let config = ncgConfig ncgImpl let platform = ncgPlatform config @@ -481,7 +473,7 @@ {-# SCC "cmmToCmm" #-} cmmToCmm config fixed_cmm - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup platform [opt_cmm]) @@ -495,11 +487,11 @@ (cmmTopCodeGen ncgImpl) fileIds dbgMap opt_cmm cmmCfg - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_native "Native code" FormatASM (vcat $ map (pprNatCmmDecl ncgImpl) native) - maybeDumpCfg logger dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name + maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name -- tag instructions with register liveness information -- also drops dead code. We don't keep the cfg in sync on @@ -512,15 +504,14 @@ initUs usGen $ mapM (cmmTopLiveness livenessCfg platform) native - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_liveness "Liveness annotations added" FormatCMM (vcat $ map (pprLiveCmmDecl platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <- - if ( gopt Opt_RegsGraph dflags - || gopt Opt_RegsIterative dflags ) + if ( ncgRegsGraph config || ncgRegsIterative config ) then do -- the regs usable for allocation let (alloc_regs :: UniqFM RegClass (UniqSet RealReg)) @@ -552,12 +543,12 @@ -- dump out what happened during register allocation - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_regalloc_stages "Build/spill stages" FormatText (vcat $ map (\(stage, stats) @@ -567,7 +558,7 @@ $ zip [0..] regAllocStats) let mPprStats = - if dopt Opt_D_dump_asm_stats dflags + if logHasDumpFlag logger Opt_D_dump_asm_stats then Just regAllocStats else Nothing -- force evaluation of the Maybe to avoid space leak @@ -596,13 +587,13 @@ $ liftM unzip3 $ mapM reg_alloc withLiveness - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) let mPprStats = - if dopt Opt_D_dump_asm_stats dflags + if logHasDumpFlag logger Opt_D_dump_asm_stats then Just (catMaybes regAllocStats) else Nothing -- force evaluation of the Maybe to avoid space leak @@ -631,7 +622,7 @@ {-# SCC "generateJumpTables" #-} generateJumpTables ncgImpl alloced - when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags + when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger Opt_D_dump_cfg_weights "CFG Update information" FormatText ( text "stack:" <+> ppr stack_updt_blks $$ @@ -640,20 +631,20 @@ ---- shortcut branches let (shorted, postShortCFG) = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags ncgImpl tabled postRegCFG + shortcutBranches config ncgImpl tabled postRegCFG let optimizedCFG :: Maybe CFG optimizedCFG = - optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG + optimizeCFG (ncgCmmStaticPred config) weights cmm <$!> postShortCFG - maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name + maybeDumpCfg logger optimizedCFG "CFG Weights - Final" proc_name --TODO: Partially check validity of the cfg. let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks getBlks _ = [] when ( backendMaintainsCfg platform && - (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do + (ncgAsmLinting config || debugIsOn )) $ do let blocks = concatMap getBlks shorted let labels = setFromList $ fmap blockId blocks :: LabelSet let cfg = fromJust optimizedCFG @@ -687,7 +678,7 @@ ncgExpandTop ncgImpl branchOpt --ncgExpandTop ncgImpl sequenced - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_expanded "Synthetic instructions expanded" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) expanded) @@ -699,7 +690,7 @@ foldl' addUnwind mapEmpty expanded where addUnwind acc proc = - acc `mapUnion` computeUnwinding dflags ncgImpl proc + acc `mapUnion` computeUnwinding config ncgImpl proc return ( usAlloc , fileIds' @@ -709,13 +700,13 @@ , ppr_raStatsLinear , unwinds ) -maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO () -maybeDumpCfg _logger _dflags Nothing _ _ = return () -maybeDumpCfg logger dflags (Just cfg) msg proc_name +maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO () +maybeDumpCfg _logger Nothing _ _ = return () +maybeDumpCfg logger (Just cfg) msg proc_name | null cfg = return () | otherwise - = dumpIfSet_dyn logger - dflags Opt_D_dump_cfg_weights msg + = putDumpFileMaybe logger + Opt_D_dump_cfg_weights msg FormatText (proc_name <> char ':' $$ pprEdgeWeights cfg) @@ -738,15 +729,16 @@ -- | Compute unwinding tables for the blocks of a procedure computeUnwinding :: Instruction instr - => DynFlags -> NcgImpl statics instr jumpDest + => NCGConfig + -> NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -- ^ the native code generated for the procedure -> LabelMap [UnwindPoint] -- ^ unwinding tables for all points of all blocks of the -- procedure -computeUnwinding dflags _ _ - | debugLevel dflags == 0 = mapEmpty -computeUnwinding _ _ (CmmData _ _) = mapEmpty +computeUnwinding config _ _ + | not (ncgComputeUnwinding config) = mapEmpty +computeUnwinding _ _ (CmmData _ _) = mapEmpty computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = -- In general we would need to push unwinding information down the -- block-level call-graph to ensure that we fully account for all @@ -832,14 +824,15 @@ -- Shortcut branches shortcutBranches - :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags + :: forall statics instr jumpDest. (Outputable jumpDest) + => NCGConfig -> NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> Maybe CFG -> ([NatCmmDecl statics instr],Maybe CFG) -shortcutBranches dflags ncgImpl tops weights - | gopt Opt_AsmShortcutting dflags +shortcutBranches config ncgImpl tops weights + | ncgEnableShortcutting config = ( map (apply_mapping ncgImpl mapping) tops' , shortcutWeightMap mappingBid <$!> weights ) | otherwise @@ -1144,56 +1137,3 @@ other -> return other - --- | Initialize the native code generator configuration from the DynFlags -initNCGConfig :: DynFlags -> Module -> NCGConfig -initNCGConfig dflags this_mod = NCGConfig - { ncgPlatform = targetPlatform dflags - , ncgThisModule = this_mod - , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle) - , ncgProcAlignment = cmmProcAlignment dflags - , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags - , ncgPIC = positionIndependent dflags - , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags - , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags - , ncgSplitSections = gopt Opt_SplitSections dflags - , ncgRegsIterative = gopt Opt_RegsIterative dflags - , ncgAsmLinting = gopt Opt_DoAsmLinting dflags - , ncgCfgWeights = cfgWeights dflags - , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags - , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags - - -- With -O1 and greater, the cmmSink pass does constant-folding, so - -- we don't need to do it again in the native code generator. - , ncgDoConstantFolding = optLevel dflags < 1 - - , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags - , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags - , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags - , ncgBmiVersion = case platformArch (targetPlatform dflags) of - ArchX86_64 -> bmiVersion dflags - ArchX86 -> bmiVersion dflags - _ -> Nothing - - -- We assume SSE1 and SSE2 operations are available on both - -- x86 and x86_64. Historically we didn't default to SSE2 and - -- SSE1 on x86, which results in defacto nondeterminism for how - -- rounding behaves in the associated x87 floating point instructions - -- because variations in the spill/fpu stack placement of arguments for - -- operations would change the precision and final result of what - -- would otherwise be the same expressions with respect to single or - -- double precision IEEE floating point computations. - , ncgSseVersion = - let v | sseVersion dflags < Just SSE2 = Just SSE2 - | otherwise = sseVersion dflags - in case platformArch (targetPlatform dflags) of - ArchX86_64 -> v - ArchX86 -> v - _ -> Nothing - - , ncgDwarfEnabled = debugLevel dflags > 0 - , ncgDwarfUnwindings = debugLevel dflags >= 1 - , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags - , ncgDwarfStripBlockInfo = debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1. - , ncgDwarfSourceNotes = debugLevel dflags >= 3 -- We produce GHC-specific source-note DIEs only with -g3 - } diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for x86 and x86-64 architectures +module GHC.CmmToAsm.AArch64 + ( ncgAArch64 ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types + +import qualified GHC.CmmToAsm.AArch64.Instr as AArch64 +import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64 +import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64 +import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 +import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64 + +ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest +ncgAArch64 config + = NcgImpl { + ncgConfig = config + ,cmmTopCodeGen = AArch64.cmmTopCodeGen + ,generateJumpTableForInstr = AArch64.generateJumpTableForInstr config + ,getJumpDestBlockId = AArch64.getJumpDestBlockId + ,canShortcut = AArch64.canShortcut + ,shortcutStatics = AArch64.shortcutStatics + ,shortcutJump = AArch64.shortcutJump + ,pprNatCmmDecl = AArch64.pprNatCmmDecl config + ,maxSpillSlots = AArch64.maxSpillSlots config + ,allocatableRegs = AArch64.allocatableRegs platform + ,ncgAllocMoreStack = AArch64.allocMoreStack platform + ,ncgExpandTop = id + ,ncgMakeFarBranches = const id + ,extractUnwindPoints = const [] + ,invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +-- | Instruction instance for aarch64 +instance Instruction AArch64.Instr where + regUsageOfInstr = AArch64.regUsageOfInstr + patchRegsOfInstr = AArch64.patchRegsOfInstr + isJumpishInstr = AArch64.isJumpishInstr + jumpDestsOfInstr = AArch64.jumpDestsOfInstr + patchJumpInstr = AArch64.patchJumpInstr + mkSpillInstr = AArch64.mkSpillInstr + mkLoadInstr = AArch64.mkLoadInstr + takeDeltaInstr = AArch64.takeDeltaInstr + isMetaInstr = AArch64.isMetaInstr + mkRegRegMoveInstr _ = AArch64.mkRegRegMoveInstr + takeRegRegMoveInstr = AArch64.takeRegRegMoveInstr + mkJumpInstr = AArch64.mkJumpInstr + mkStackAllocInstr = AArch64.mkStackAllocInstr + mkStackDeallocInstr = AArch64.mkStackDeallocInstr + mkComment = pure . AArch64.COMMENT + pprInstr = AArch64.pprInstr diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -0,0 +1,1452 @@ +{-# language GADTs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +module GHC.CmmToAsm.AArch64.CodeGen ( + cmmTopCodeGen + , generateJumpTableForInstr +) + +where + +-- NCG stuff: +import GHC.Prelude hiding (EQ) + +import GHC.Platform.Regs +import GHC.CmmToAsm.AArch64.Instr +import GHC.CmmToAsm.AArch64.Regs +import GHC.CmmToAsm.AArch64.Cond + +import GHC.CmmToAsm.CPrim +import GHC.Cmm.DebugBlock +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat + , getPicBaseMaybeNat, getPlatform, getConfig + , getDebugBlock, getFileId + ) +-- import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Platform.Reg +import GHC.Platform + +-- Our intermediate code: +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Types.Tickish ( GenTickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import GHC.Data.OrdList +import GHC.Utils.Outputable + +import Control.Monad ( mapAndUnzipM, when, foldM ) +import Data.Word +import Data.Maybe +import GHC.Float + +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Panic + +-- Note [General layout of an NCG] +-- @cmmTopCodeGen@ will be our main entry point to code gen. Here we'll get +-- @RawCmmDecl@; see GHC.Cmm +-- +-- RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph +-- +-- GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g +-- | CmmData Section d +-- +-- As a result we want to transform this to a list of @NatCmmDecl@, which is +-- defined @GHC.CmmToAsm.Instr@ as +-- +-- type NatCmmDecl statics instr +-- = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr) +-- +-- Thus well' turn +-- GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph +-- into +-- [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)] +-- +-- where @CmmGraph@ is +-- +-- type CmmGraph = GenCmmGraph CmmNode +-- data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +-- type CmmBlock = Block CmmNode C C +-- +-- and @ListGraph Instr@ is +-- +-- newtype ListGraph i = ListGraph [GenBasicBlock i] +-- data GenBasicBlock i = BasicBlock BlockId [i] + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl RawCmmStatics Instr] + +-- Thus we'll have to deal with either CmmProc ... +cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do + -- do + -- traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n" + -- ++ showSDocUnsafe (ppr cmm) + + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + + case picBaseMb of + Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented" + Nothing -> return tops + +-- ... or CmmData. +cmmTopCodeGen _cmm@(CmmData sec dat) = do + -- do + -- traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n" + -- ++ showSDocUnsafe (ppr cmm) + return [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen + :: Block CmmNode C C + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl RawCmmStatics Instr]) + +basicBlockCodeGen block = do + config <- getConfig + -- do + -- traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + -- ++ showSDocUnsafe (ppr block) + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + + header_comment_instr = unitOL $ MULTILINE_COMMENT ( + text "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + $+$ pdoc (ncgPlatform config) block + ) + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span name) + -> do fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + return $ unitOL $ LOCATION fileId line col name + _ -> return nilOL + (mid_instrs,mid_bid) <- stmtsToInstrs id stmts + (!tail_instrs,_) <- stmtToInstrs mid_bid tail + let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs + -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts + -- unwinding info. See Ticket 19913 + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + + +-- ----------------------------------------------------------------------------- +-- | Utilities +ann :: SDoc -> Instr -> Instr +ann doc instr {- | debugIsOn -} = ANN doc instr +-- ann _ instr = instr +{-# INLINE ann #-} + +-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with +-- -dppr-debug. The idea is that we can trivially see how a cmm expression +-- ended up producing the assmebly we see. By having the verbatim AST printed +-- we can simply check the patterns that were matched to arrive at the assmebly +-- we generated. +-- +-- pprExpr will hide a lot of noise of the underlying data structure and print +-- the expression into something that can be easily read by a human. However +-- going back to the exact CmmExpr representation can be labourous and adds +-- indirections to find the matches that lead to the assembly. +-- +-- An improvement oculd be to have +-- +-- (pprExpr genericPlatform e) <> parens (text. show e) +-- +-- to have the best of both worlds. +-- +-- Note: debugIsOn is too restrictive, it only works for debug compilers. +-- However, we do not only want to inspect this for debug compilers. Ideally +-- we'd have a check for -dppr-debug here already, such that we don't even +-- generate the ANN expressions. However, as they are lazy, they shouldn't be +-- forced until we actually force them, and without -dppr-debug they should +-- never end up being forced. +annExpr :: CmmExpr -> Instr -> Instr +annExpr e instr {- | debugIsOn -} = ANN (text . show $ e) instr +-- annExpr e instr {- | debugIsOn -} = ANN (pprExpr genericPlatform e) instr +-- annExpr _ instr = instr +{-# INLINE annExpr #-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +-- TODO jump tables would be a lot faster, but we'll use bare bones for now. +-- this is usually done by sticking the jump table ids into an instruction +-- and then have the @generateJumpTableForInstr@ callback produce the jump +-- table as a static. +-- +-- See Ticket 19912 +-- +-- data SwitchTargets = +-- SwitchTargets +-- Bool -- Signed values +-- (Integer, Integer) -- Range +-- (Maybe Label) -- Default value +-- (M.Map Integer Label) -- The branches +-- +-- Non Jumptable plan: +-- xE <- expr +-- +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch expr targets = do -- pprPanic "genSwitch" (ppr expr) + (reg, format, code) <- getSomeReg expr + let w = formatToWidth format + let mkbranch acc (key, bid) = do + (keyReg, _format, code) <- getSomeReg (CmmLit (CmmInt key w)) + return $ code `appOL` + toOL [ CMP (OpReg w reg) (OpReg w keyReg) + , BCOND EQ (TBlock bid) + ] `appOL` acc + def_code = case switchTargetsDefault targets of + Just bid -> unitOL (B (TBlock bid)) + Nothing -> nilOL + + switch_code <- foldM mkbranch nilOL (switchTargetsCases targets) + return $ code `appOL` switch_code `appOL` def_code + +-- We don't do jump tables for now, see Ticket 19912 +generateJumpTableForInstr :: NCGConfig -> Instr + -> Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +-- See Note [Keeping track of the current block] for why +-- we pass the BlockId. +stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. + -> [CmmNode O O] -- ^ Cmm Statement + -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction +stmtsToInstrs bid stmts = + go bid stmts nilOL + where + go bid [] instrs = return (instrs,bid) + go bid (s:stmts) instrs = do + (instrs',bid') <- stmtToInstrs bid s + -- If the statement introduced a new block, we use that one + let !newBid = fromMaybe bid bid' + go newBid stmts (instrs `appOL` instrs') + +-- | `bid` refers to the current block and is used to update the CFG +-- if new blocks are inserted in the control flow. +-- See Note [Keeping track of the current block] for more details. +stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. + -> CmmNode e x + -> NatM (InstrBlock, Maybe BlockId) + -- ^ Instructions, and bid of new block if successive + -- statements are placed in a different basic block. +stmtToInstrs bid stmt = do + -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n" + -- ++ showSDocUnsafe (ppr stmt) + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args bid + + _ -> (,Nothing) <$> case stmt of + CmmComment s -> return (unitOL (COMMENT (ftext s))) + CmmTick {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType platform reg + format = cmmTypeFormat ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _prediction -> + genCondBranch bid true false arg + + CmmSwitch arg ids -> genSwitch arg ids + + CmmCall { cml_target = arg } -> genJump arg + + CmmUnwind _regs -> return nilOL + + _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + +-- | Sometimes we need to change the Format of a register. Primarily during +-- conversion. +swizzleRegisterRep :: Format -> Register -> Register +swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code +swizzleRegisterRep format (Any _ codefn) = Any format codefn + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence if it's not mapped to a registers something + -- went wrong earlier in the pipeline. +-- | Convert a BlockId to some CmmStatic data +-- TODO: Add JumpTable Logic, see Ticket 19912 +-- jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +-- jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) +-- jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +-- where blockLabel = blockLbl blockid + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Fixed rep reg code -> + return (reg, rep, code) + +-- TODO OPT: we might be able give getRegister +-- a hint, what kind of register we want. +getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg expr = do + r <- getRegister expr + case r of + Any rep code | isFloatFormat rep -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Any II32 code -> do + tmp <- getNewRegNat FF32 + return (tmp, FF32, code tmp) + Any II64 code -> do + tmp <- getNewRegNat FF64 + return (tmp, FF64, code tmp) + Any _w _code -> do + config <- getConfig + pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) + -- can't do much for fixed. + Fixed rep reg code -> + return (reg, rep, code) + +-- TODO: TODO, bounds. We can't put any immediate +-- value in. They are constrained. +-- See Ticket 19911 +litToImm' :: CmmLit -> NatM (Operand, InstrBlock) +litToImm' lit = return (OpImm (litToImm lit), nilOL) + + +getRegister :: CmmExpr -> NatM Register +getRegister e = do + config <- getConfig + getRegister' config (ncgPlatform config) e + +-- Note [Handling PIC on AArch64] +-- AArch64 does not have a special PIC register, the general approach is to +-- simply go through the GOT, and there is assembly support for this: +-- +-- // Load the address of 'sym' from the GOT using ADRP and LDR (used for +-- // position-independent code on AArch64): +-- adrp x0, #:got:sym +-- ldr x0, [x0, #:got_lo12:sym] +-- +-- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions +-- +-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the +-- @cmmMakePicReference@. This is in turn called from @cmmMakeDynamicReference@ +-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported. There are two +-- callsites for this. One is in this module to produce the @target@ in @genCCall@ +-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@. +-- +-- Conceptually we do not want any special PicBaseReg to be used on AArch64. If +-- we want to distinguish between symbol loading, we need to address this through +-- the way we load it, not through a register. +-- + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register +-- OPTIMIZATION WARNING: CmmExpr rewrites +-- 1. Rewrite: Reg + (-n) => Reg - n +-- TODO: this expression souldn't even be generated to begin with. +getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0 + = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)]) + +getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0 + = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)]) + + +-- Generic case. +getRegister' config plat expr + = case expr of + CmmReg (CmmGlobal PicBaseReg) + -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg) + CmmLit lit + -> case lit of + + -- TODO handle CmmInt 0 specially, use wzr or xzr. + + CmmInt i W8 -> do + return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowS W8 i)))))) + CmmInt i W16 -> do + return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowS W16 i)))))) + + -- We need to be careful to not shorten this for negative literals. + -- Those need the upper bits set. We'd either have to explicitly sign + -- or figure out something smarter. Lowered to + -- `MOV dst XZR` + CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i))))) + CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + return (Any (intFormat w) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) + ])) + -- fallback for W32 + CmmInt i W32 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + return (Any (intFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) + ])) + -- anything else + CmmInt i W64 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) + return (Any (intFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48) + ])) + CmmInt _i rep -> do + (op, imm_code) <- litToImm' lit + return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op))) + + -- floatToBytes (fromRational f) + CmmFloat 0 w -> do + (op, imm_code) <- litToImm' lit + return (Any (floatFormat w) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg w dst) op))) + + CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr) + CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr) + CmmFloat f W32 -> do + let word = castFloatToWord32 (fromRational f) :: Word32 + half0 = fromIntegral (fromIntegral word :: Word16) + half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) + tmp <- getNewRegNat (intFormat W32) + return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16) + , MOV (OpReg W32 dst) (OpReg W32 tmp) + ])) + CmmFloat f W64 -> do + let word = castDoubleToWord64 (fromRational f) :: Word64 + half0 = fromIntegral (fromIntegral word :: Word16) + half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16) + tmp <- getNewRegNat (intFormat W64) + return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0)) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48) + , MOV (OpReg W64 dst) (OpReg W64 tmp) + ])) + CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) + CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) + CmmLabel _lbl -> do + (op, imm_code) <- litToImm' lit + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op))) + + CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do + (op, imm_code) <- litToImm' lit + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + -- width = typeWidth rep + return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op)) + + CmmLabelOff lbl off -> do + (op, imm_code) <- litToImm' (CmmLabel lbl) + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + width = typeWidth rep + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + return (Any format (\dst -> imm_code `appOL` off_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r))) + + CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmLoad mem rep -> do + Amode addr addr_code <- getAmode plat mem + let format = cmmTypeFormat rep + return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr))) + CmmStackSlot _ _ + -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) + CmmReg reg + -> return (Fixed (cmmTypeFormat (cmmRegType plat reg)) + (getRegisterReg plat reg) + nilOL) + CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do + getRegister' config plat $ + CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType plat reg) + + CmmRegOff reg off -> do + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + (reg, _format, code) <- getSomeReg $ CmmReg reg + return $ Any (intFormat width) (\dst -> off_code `appOL` code `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r)) + where width = typeWidth (cmmRegType plat reg) + + + + -- for MachOps, see GHC.Cmm.MachOp + -- For CmmMachOp, see GHC.Cmm.Expr + CmmMachOp op [e] -> do + (reg, _format, code) <- getSomeReg e + case op of + MO_Not w -> return $ Any (intFormat w) (\dst -> code `snocOL` MVN (OpReg w dst) (OpReg w reg)) + + MO_S_Neg w -> return $ Any (intFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg)) + MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg)) + + MO_SF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) + MO_FS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed) + + -- TODO this is very hacky + -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@ + -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend). + MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to))) + MO_SS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` SBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to))) + MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg)) + + -- Conversions + MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + + _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr) + where toImm W8 = (OpImm (ImmInt 7)) + toImm W16 = (OpImm (ImmInt 15)) + toImm W32 = (OpImm (ImmInt 31)) + toImm W64 = (OpImm (ImmInt 63)) + toImm W128 = (OpImm (ImmInt 127)) + toImm W256 = (OpImm (ImmInt 255)) + toImm W512 = (OpImm (ImmInt 511)) + -- Dyadic machops: + -- + -- The general idea is: + -- compute x <- x + -- compute x <- y + -- OP x, x, x + -- + -- TODO: for now we'll only implement the 64bit versions. And rely on the + -- fallthrough to alert us if things go wrong! + -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring + -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg + CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + -- 1. Compute Reg +/- n directly. + -- For Add/Sub we can directly encode 12bits, or 12bits lsl #12. + CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)] + | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. + where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + r' = getRegisterReg plat reg + CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)] + | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. + where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + r' = getRegisterReg plat reg + + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + -- 2. Shifts. x << n, x >> n. + CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))) + CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))) + CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))) + CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))) + CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + -- 3. Logic &&, || + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + r' = getRegisterReg plat reg + + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + r' = getRegisterReg plat reg + + -- Generic case. + CmmMachOp op [x, y] -> do + -- alright, so we have an operation, and two expressions. And we want to essentially do + -- ensure we get float regs + let genOp w op = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + when ((isFloatFormat format_x && isIntFormat format_y) || (isIntFormat format_x && isFloatFormat format_y)) $ pprPanic "getRegister:genOp" (text "formats don't match:" <+> text (show format_x) <+> text "/=" <+> text (show format_y)) + return $ Any format_x (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) + + withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op + -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op + + intOp w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) + floatOp w op = do + (reg_fx, _format_x, code_fx) <- getFloatReg x + (reg_fy, _format_y, code_fy) <- getFloatReg y + return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + -- need a special one for conditionals, as they return ints + floatCond w op = do + (reg_fx, _format_x, code_fx) <- getFloatReg x + (reg_fy, _format_y, code_fy) <- getFloatReg y + return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + case op of + -- Integer operations + -- Add/Sub should only be Interger Options. + -- But our Cmm parser doesn't care about types + -- and thus we end up with + => MO_Add + MO_Add w -> genOp w (\d x y -> unitOL $ annExpr expr (ADD d x y)) + MO_Sub w -> genOp w (\d x y -> unitOL $ annExpr expr (SUB d x y)) + + -- Note [CSET] + -- + -- Setting conditional flags: the architecture internally knows the + -- following flag bits. And based on thsoe comparisons as in the + -- table below. + -- + -- 31 30 29 28 + -- .---+---+---+---+-- - - + -- | N | Z | C | V | + -- '---+---+---+---+-- - - + -- Negative + -- Zero + -- Carry + -- oVerflow + -- + -- .------+-------------------------------------+-----------------+----------. + -- | Code | Meaning | Flags | Encoding | + -- |------+-------------------------------------+-----------------+----------| + -- | EQ | Equal | Z = 1 | 0000 | + -- | NE | Not Equal | Z = 0 | 0001 | + -- | HI | Unsigned Higher | C = 1 && Z = 0 | 1000 | + -- | HS | Unsigned Higher or Same | C = 1 | 0010 | + -- | LS | Unsigned Lower or Same | C = 0 || Z = 1 | 1001 | + -- | LO | Unsigned Lower | C = 0 | 0011 | + -- | GT | Signed Greater Than | Z = 0 && N = V | 1100 | + -- | GE | Signed Greater Than or Equal | N = V | 1010 | + -- | LE | Signed Less Than or Equal | Z = 1 || N /= V | 1101 | + -- | LT | Signed Less Than | N /= V | 1011 | + -- | CS | Carry Set (Unsigned Overflow) | C = 1 | 0010 | + -- | CC | Carry Clear (No Unsigned Overflow) | C = 0 | 0011 | + -- | VS | Signed Overflow | V = 1 | 0110 | + -- | VC | No Signed Overflow | V = 0 | 0111 | + -- | MI | Minus, Negative | N = 1 | 0100 | + -- | PL | Plus, Positive or Zero (!) | N = 0 | 0101 | + -- | AL | Always | Any | 1110 | + -- | NV | Never | Any | 1111 | + --- '-------------------------------------------------------------------------' + MO_Eq w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d EQ ]) + MO_Eq w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d EQ ]) + MO_Eq w -> intOp w (\d x y -> toOL [ CMP x y, CSET d EQ ]) + MO_Ne w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d NE ]) + MO_Ne w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d NE ]) + MO_Ne w -> intOp w (\d x y -> toOL [ CMP x y, CSET d NE ]) + MO_Mul w -> intOp w (\d x y -> unitOL $ MUL d x y) + + -- Signed multiply/divide + MO_S_MulMayOflo w -> intOp w (\d x y -> toOL [ MUL d x y, CSET d VS ]) + MO_S_Quot w -> intOp w (\d x y -> unitOL $ SDIV d x y) + + -- No native rem instruction. So we'll compute the following + -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry + -- Rd' <- Rx - Rd * Ry | 1 <- 7 - 2 * 3 -- MSUB Rd' Rd Ry Rx + -- | '---|----------------|---' | + -- | '----------------|-------' + -- '--------------------------' + -- Note the swap in Rx and Ry. + MO_S_Rem w -> withTempIntReg w $ \t -> + intOp w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) + + -- Unsigned multiply/divide + MO_U_MulMayOflo _w -> unsupportedP plat expr + MO_U_Quot w -> intOp w (\d x y -> unitOL $ UDIV d x y) + MO_U_Rem w -> withTempIntReg w $ \t -> + intOp w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) + + -- Signed comparisons -- see Note [CSET] + MO_S_Ge w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SGE ]) + MO_S_Ge w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SGE ]) + MO_S_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGE ]) + MO_S_Le w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SLE ]) + MO_S_Le w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SLE ]) + MO_S_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLE ]) + MO_S_Gt w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SGT ]) + MO_S_Gt w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SGT ]) + MO_S_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGT ]) + MO_S_Lt w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SLT ]) + MO_S_Lt w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SLT ]) + MO_S_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLT ]) + + -- Unsigned comparisons + MO_U_Ge w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d UGE ]) + MO_U_Ge w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d UGE ]) + MO_U_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGE ]) + MO_U_Le w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d ULE ]) + MO_U_Le w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d ULE ]) + MO_U_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULE ]) + MO_U_Gt w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d UGT ]) + MO_U_Gt w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d UGT ]) + MO_U_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGT ]) + MO_U_Lt w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d ULT ]) + MO_U_Lt w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d ULT ]) + MO_U_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULT ]) + + -- Floating point arithmetic + MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y) + MO_F_Sub w -> floatOp w (\d x y -> unitOL $ SUB d x y) + MO_F_Mul w -> floatOp w (\d x y -> unitOL $ MUL d x y) + MO_F_Quot w -> floatOp w (\d x y -> unitOL $ SDIV d x y) + + -- Floating point comparison + MO_F_Eq w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ]) + MO_F_Ne w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ]) + + -- careful with the floating point operations. + -- SLE is effectively LE or unordered (NaN) + -- SLT is the same. ULE, and ULT will not return true for NaN. + -- This is a bit counter intutive. Don't let yourself be fooled by + -- the S/U prefix for floats, it's only meaningful for integers. + MO_F_Ge w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ]) + MO_F_Le w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x + MO_F_Gt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ]) + MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x + + -- Bitwise operations + MO_And w -> intOp w (\d x y -> unitOL $ AND d x y) + MO_Or w -> intOp w (\d x y -> unitOL $ ORR d x y) + MO_Xor w -> intOp w (\d x y -> unitOL $ EOR d x y) + -- MO_Not W64 -> + MO_Shl w -> intOp w (\d x y -> unitOL $ LSL d x y) + MO_U_Shr w -> intOp w (\d x y -> unitOL $ LSR d x y) + MO_S_Shr w -> intOp w (\d x y -> unitOL $ ASR d x y) + + -- TODO + + op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + CmmMachOp _op _xs + -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) + + where + unsupportedP :: OutputableP env a => env -> a -> b + unsupportedP platform op = pprPanic "Unsupported op:" (pdoc platform op) + + isNbitEncodeable :: Int -> Integer -> Bool + isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + -- This needs to check if n can be encoded as a bitmask immediate: + -- + -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly + -- + isBitMaskImmediate :: Integer -> Bool + isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000 + ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000 + ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000 + ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000 + ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000 + ,0b0011_1111, 0b0111_1110, 0b1111_1100 + ,0b0111_1111, 0b1111_1110 + ,0b1111_1111] + + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. +data Amode = Amode AddrMode InstrBlock + +getAmode :: Platform -> CmmExpr -> NatM Amode +-- TODO: Specialize stuff we can destructure here. + +-- OPTIMIZATION WARNING: Addressing modes. +-- Addressing options: +-- LDUR/STUR: imm9: -256 - 255 +getAmode platform (CmmRegOff reg off) | -256 <= off, off <= 255 + = return $ Amode (AddrRegImm reg' off') nilOL + where reg' = getRegisterReg platform reg + off' = ImmInt off +-- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4 +getAmode platform (CmmRegOff reg off) + | typeWidth (cmmRegType platform reg) == W32, 0 <= off, off <= 16380, off `mod` 4 == 0 + = return $ Amode (AddrRegImm reg' off') nilOL + where reg' = getRegisterReg platform reg + off' = ImmInt off +-- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8 +getAmode platform (CmmRegOff reg off) + | typeWidth (cmmRegType platform reg) == W64, 0 <= off, off <= 32760, off `mod` 8 == 0 + = return $ Amode (AddrRegImm reg' off') nilOL + where reg' = getRegisterReg platform reg + off' = ImmInt off + +-- For Stores we often see something like this: +-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) +-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] +-- for `n` in range. +getAmode _platform (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) + | -256 <= off, off <= 255 + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger off)) code + +getAmode _platform (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) + | -256 <= -off, -off <= 255 + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger (-off))) code + +-- Generic case +getAmode _platform expr + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrReg reg) code + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode rep addrE srcE + = do + (src_reg, _format, code) <- getSomeReg srcE + platform <- getPlatform + Amode addr addr_code <- getAmode platform addrE + return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) + `consOL` (code + `appOL` addr_code + `snocOL` STR rep (OpReg (formatToWidth rep) src_reg) (OpAddr addr)) + +assignReg_IntCode _ reg src + = do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst + Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` (fcode `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg)) + +-- Let's treat Floating point stuff +-- as integer code for now. Opaque. +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + +-- ----------------------------------------------------------------------------- +-- Jumps +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock +genJump expr@(CmmLit (CmmLabel lbl)) + = return $ unitOL (annExpr expr (J (TLabel lbl))) + +genJump expr = do + (target, _format, code) <- getSomeReg expr + return (code `appOL` unitOL (annExpr expr (J (TReg target)))) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump + :: BlockId + -> CmmExpr + -> NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (CBZ (OpReg w reg_x) (TBlock bid))) + + -- Optimized /= 0 case. + CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (CBNZ (OpReg w reg_x) (TBlock bid))) + + -- Generic case. + CmmMachOp mop [x, y] -> do + + let ubcond w cmp = do + -- compute both sides. + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + let x' = OpReg w reg_x + y' = OpReg w reg_y + return $ case w of + W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + + sbcond w cmp = do + -- compute both sides. + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + let x' = OpReg w reg_x + y' = OpReg w reg_y + return $ case w of + W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + + fbcond w cmp = do + -- ensure we get float regs + (reg_fx, _format_fx, code_fx) <- getFloatReg x + (reg_fy, _format_fy, code_fy) <- getFloatReg y + return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (TBlock bid))) + + case mop of + MO_F_Eq w -> fbcond w EQ + MO_F_Ne w -> fbcond w NE + + MO_F_Gt w -> fbcond w OGT + MO_F_Ge w -> fbcond w OGE + MO_F_Lt w -> fbcond w OLT + MO_F_Le w -> fbcond w OLE + + MO_Eq w -> sbcond w EQ + MO_Ne w -> sbcond w NE + + MO_S_Gt w -> sbcond w SGT + MO_S_Ge w -> sbcond w SGE + MO_S_Lt w -> sbcond w SLT + MO_S_Le w -> sbcond w SLE + MO_U_Gt w -> ubcond w UGT + MO_U_Ge w -> ubcond w UGE + MO_U_Lt w -> ubcond w ULT + MO_U_Le w -> ubcond w ULE + _ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr) + _ -> pprPanic "AArch64.genCondJump: " (text $ show expr) + + +genCondBranch + :: BlockId -- the source of the jump + -> BlockId -- the true branch target + -> BlockId -- the false branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock -- Instructions + +genCondBranch _ true false expr = do + b1 <- genCondJump true expr + b2 <- genBranch false + return (b1 `appOL` b2) + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- As per *convention*: +-- x0-x7: (volatile) argument registers +-- x8: (volatile) indirect result register / Linux syscall no +-- x9-x15: (volatile) caller saved regs +-- x16,x17: (volatile) intra-procedure-call registers +-- x18: (volatile) platform register. don't use for portability +-- x19-x28: (non-volatile) callee save regs +-- x29: (non-volatile) frame pointer +-- x30: link register +-- x31: stack pointer / zero reg +-- +-- Thus, this is what a c function will expect. Find the arguments in x0-x7, +-- anything above that on the stack. We'll ignore c functions with more than +-- 8 arguments for now. Sorry. +-- +-- We need to make sure we preserve x9-x15, don't want to touch x16, x17. + +-- Note [PLT vs GOT relocations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When linking objects together, we may need to lookup foreign references. That +-- is symbolic references to functions or values in other objects. When +-- compiling the object, we can not know where those elements will end up in +-- memory (relative to the current location). Thus the use of symbols. There +-- are two types of items we are interested, code segments we want to jump to +-- and continue execution there (functions, ...), and data items we want to look +-- up (strings, numbers, ...). For functions we can use the fact that we can use +-- an intermediate jump without visibility to the programs execution. If we +-- want to jump to a function that is simply too far away to reach for the B/BL +-- instruction, we can create a small piece of code that loads the full target +-- address and jumps to that on demand. Say f wants to call g, however g is out +-- of range for a direct jump, we can create a function h in range for f, that +-- will load the address of g, and jump there. The area where we construct h +-- is called the Procedure Linking Table (PLT), we have essentially replaced +-- f -> g with f -> h -> g. This is fine for function calls. However if we +-- want to lookup values, this trick doesn't work, so we need something else. +-- We will instead reserve a slot in memory, and have a symbol pointing to that +-- slot. Now what we essentially do is, we reference that slot, and expect that +-- slot to hold the final resting address of the data we are interested in. +-- Thus what that symbol really points to is the location of the final data. +-- The block of memory where we hold all those slots is the Global Offset Table +-- (GOT). Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y]. +-- +-- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only +-- have 19bits (+/- 1MB). Symbol lookups are also within +/- 1MB, thus for most +-- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within +-- 4GB of the PC, and load that. For anything outside of that range, we'd have +-- to go through the GOT. +-- +-- adrp x0, +-- add x0, :lo: +-- +-- will compute the address of int x0 if is within 4GB of the +-- PC. +-- +-- If we want to get the slot in the global offset table (GOT), we can do this: +-- +-- adrp x0, #:got: +-- ldr x0, [x0, #:got_lo12:] +-- +-- this will compute the address anywhere in the addressable 64bit space into +-- x0, by loading the address from the GOT slot. +-- +-- To actually get the value of , we'd need to ldr x0, x0 still, which +-- for the first case can be optimized to use ldr x0, [x0, #:lo12:] +-- instaed of the add instruction. +-- +-- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do +-- not need to go through the GOT, unless we want to address the full address +-- range within 64bit. + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> BlockId -- The block we are in + -> NatM (InstrBlock, Maybe BlockId) +-- TODO: Specialize where we can. +-- Generic impl +genCCall target dest_regs arg_regs bid = do + -- we want to pass arg_regs into allArgRegs + -- pprTraceM "genCCall target" (ppr target) + -- pprTraceM "genCCall formal" (ppr dest_regs) + -- pprTraceM "genCCall actual" (ppr arg_regs) + + case target of + -- The target :: ForeignTarget call can either + -- be a foreign procedure with an address expr + -- and a calling convention. + ForeignTarget expr _cconv -> do + (call_target, call_target_code) <- case expr of + -- if this is a label, let's just directly to it. This will produce the + -- correct CALL relocation for BL... + (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) + -- ... if it's not a label--well--let's compute the expression into a + -- register and jump to that. See Note [PLT vs GOT relocations] + _ -> do (reg, _format, reg_code) <- getSomeReg expr + pure (TReg reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this thenn breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + 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 + + -- if we pack the stack, we may need to adjust to multiple of 8byte. + -- if we don't pack the stack, it will always be multiple of 8. + let stackSpace = if stackSpace' `mod` 8 /= 0 + then 8 * (stackSpace' `div` 8 + 1) + else stackSpace' + + (returnRegs, readResultsCode) <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + + let moveStackDown 0 = toOL [ PUSH_STACK_FRAME + , DELTA (-16) ] + moveStackDown i | odd i = moveStackDown (i + 1) + moveStackDown i = toOL [ PUSH_STACK_FRAME + , SUB (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i))) + , DELTA (-8 * i - 16) ] + moveStackUp 0 = toOL [ POP_STACK_FRAME + , DELTA 0 ] + moveStackUp i | odd i = moveStackUp (i + 1) + moveStackUp i = toOL [ ADD (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i))) + , POP_STACK_FRAME + , DELTA 0 ] + + 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` readResultsCode -- parse the results into registers + `appOL` moveStackUp (stackSpace `div` 8) + return (code, Nothing) + + -- or a possibly side-effecting machine operation + -- mop :: CallishMachOp (see GHC.Cmm.MachOp) + PrimTarget mop -> do + -- We'll need config to construct forien targets + case mop of + -- 64 bit float ops + MO_F64_Pwr -> mkCCall "pow" + + MO_F64_Sin -> mkCCall "sin" + MO_F64_Cos -> mkCCall "cos" + MO_F64_Tan -> mkCCall "tan" + + MO_F64_Sinh -> mkCCall "sinh" + MO_F64_Cosh -> mkCCall "cosh" + MO_F64_Tanh -> mkCCall "tanh" + + MO_F64_Asin -> mkCCall "asin" + MO_F64_Acos -> mkCCall "acos" + MO_F64_Atan -> mkCCall "atan" + + MO_F64_Asinh -> mkCCall "asinh" + MO_F64_Acosh -> mkCCall "acosh" + MO_F64_Atanh -> mkCCall "atanh" + + MO_F64_Log -> mkCCall "log" + 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" + + MO_F32_Sin -> mkCCall "sinf" + MO_F32_Cos -> mkCCall "cosf" + MO_F32_Tan -> mkCCall "tanf" + MO_F32_Sinh -> mkCCall "sinhf" + MO_F32_Cosh -> mkCCall "coshf" + MO_F32_Tanh -> mkCCall "tanhf" + MO_F32_Asin -> mkCCall "asinf" + MO_F32_Acos -> mkCCall "acosf" + MO_F32_Atan -> mkCCall "atanf" + MO_F32_Asinh -> mkCCall "asinhf" + MO_F32_Acosh -> mkCCall "acoshf" + MO_F32_Atanh -> mkCCall "atanhf" + MO_F32_Log -> mkCCall "logf" + MO_F32_Log1P -> mkCCall "log1pf" + MO_F32_Exp -> mkCCall "expf" + MO_F32_ExpM1 -> mkCCall "expm1f" + MO_F32_Fabs -> mkCCall "fasbf" + MO_F32_Sqrt -> mkCCall "sqrtf" + + -- Conversion + MO_UF_Conv w -> mkCCall (word2FloatLabel w) + + -- 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 + MO_Add2 _w -> unsupported mop + MO_AddWordC _w -> unsupported mop + MO_SubWordC _w -> unsupported mop + MO_AddIntC _w -> unsupported mop + MO_SubIntC _w -> unsupported mop + MO_U_Mul2 _w -> unsupported mop + + -- Memory Ordering + -- TODO DMBSY is probably *way* too much! + MO_ReadBarrier -> return (unitOL DMBSY, Nothing) + MO_WriteBarrier -> return (unitOL DMBSY, Nothing) + MO_Touch -> return (nilOL, Nothing) -- Keep variables live (when using interior pointers) + -- Prefetch + MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint. + + -- Memory copy/set/move/cmp, with alignment for optimization + + -- TODO Optimize and use e.g. quad registers to move memory around instead + -- of offloading this to memcpy. For small memcpys we can utilize + -- the 128bit quad registers in NEON to move block of bytes around. + -- Might also make sense of small memsets? Use xzr? What's the function + -- call overhead? + MO_Memcpy _align -> mkCCall "memcpy" + MO_Memset _align -> mkCCall "memset" + MO_Memmove _align -> mkCCall "memmove" + MO_Memcmp _align -> mkCCall "memcmp" + + MO_SuspendThread -> mkCCall "suspendThread" + MO_ResumeThread -> mkCCall "resumeThread" + + 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_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) + MO_AtomicRead w -> mkCCall (atomicReadLabel w) + MO_AtomicWrite w -> mkCCall (atomicWriteLabel w) + MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) + -- -- Should be an AtomicRMW variant eventually. + -- -- Sequential consistent. + -- TODO: this should be implemented properly! + MO_Xchg w -> mkCCall (xchgLabel w) + + where + unsupported :: Show a => a -> b + unsupported mop = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId) + mkCCall name = do + config <- getConfig + target <- cmmMakeDynamicReference config CallReference $ + mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction + let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn + genCCall (ForeignTarget target cconv) dest_regs arg_regs bid + + -- TODO: Optimize using paired stores and loads (STP, LDP). It is + -- automomatically done by the allocator for us. However it's not optimal, + -- as we'd rather want to have control over + -- all spill/load registers, so we can optimize with instructions like + -- STP xA, xB, [sp, #-16]! + -- and + -- LDP xA, xB, sp, #16 + -- + passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) + passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode) + -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace)) + -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1))) + -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do + -- -- allocate this on the stack + -- (r0, format0, code_r0) <- getSomeReg arg0 + -- (r1, format1, code_r1) <- getSomeReg arg1 + -- let w0 = formatToWidth format0 + -- w1 = formatToWidth format1 + -- stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8))) + -- passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode) + + -- float promotion. + -- According to + -- ISO/IEC 9899:2018 + -- Information technology — Programming languages — C + -- + -- e.g. + -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf + -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf + -- + -- GHC would need to know the prototype. + -- + -- > If the expression that denotes the called function has a type that does not include a + -- > prototype, the integer promotions are performed on each argument, and arguments that + -- > have type float are promoted to double. + -- + -- As we have no way to get prototypes for C yet, we'll *not* promote this + -- which is in line with the x86_64 backend :( + -- + -- See the encode_values.cmm test. + -- + -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg) + -- if w == W32. But *only* if we don't have a prototype m( + -- + -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture + -- + -- Still have GP regs, and we want to pass an GP argument. + passArguments pack (gpReg:gpRegs) fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass gp argument: " <> ppr r) $ MOV (OpReg w gpReg) (OpReg w r))) + + -- Still have FP regs, and we want to pass an FP argument. + passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass fp argument: " <> ppr r) $ MOV (OpReg w fpReg) (OpReg w r))) + + -- No mor regs left to pass. Must pass on stack. + passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace)))) + passArguments pack [] [] args (stackSpace+space) accumRegs (stackCode `appOL` accumCode) + + -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. + passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace)))) + passArguments pack [] fpRegs args (stackSpace+space) accumRegs (stackCode `appOL` accumCode) + + -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then. + passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace)))) + passArguments pack gpRegs [] args (stackSpace+space) accumRegs (stackCode `appOL` accumCode) + + passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + + readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock) + readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode) + readResults [] _ _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) + readResults _ [] _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target) + readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do + -- gp/fp reg -> dst + platform <- getPlatform + let rep = cmmRegType platform (CmmLocal dst) + format = cmmTypeFormat rep + w = cmmRegWidth platform (CmmLocal dst) + r_dst = getRegisterReg platform (CmmLocal dst) + if isFloatFormat format + then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) + else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)) diff --git a/compiler/GHC/CmmToAsm/AArch64/Cond.hs b/compiler/GHC/CmmToAsm/AArch64/Cond.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64/Cond.hs @@ -0,0 +1,66 @@ +module GHC.CmmToAsm.AArch64.Cond where + +import GHC.Prelude + +-- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions + +-- TODO: This appears to go a bit overboard? Maybe we should stick with what LLVM +-- settled on for fcmp? +-- false: always yields false, regardless of operands. +-- oeq: yields true if both operands are not a QNAN and op1 is equal to op2. +-- ogt: yields true if both operands are not a QNAN and op1 is greater than op2. +-- oge: yields true if both operands are not a QNAN and op1 is greater than or equal to op2. +-- olt: yields true if both operands are not a QNAN and op1 is less than op2. +-- ole: yields true if both operands are not a QNAN and op1 is less than or equal to op2. +-- one: yields true if both operands are not a QNAN and op1 is not equal to op2. +-- ord: yields true if both operands are not a QNAN. +-- ueq: yields true if either operand is a QNAN or op1 is equal to op2. +-- ugt: yields true if either operand is a QNAN or op1 is greater than op2. +-- uge: yields true if either operand is a QNAN or op1 is greater than or equal to op2. +-- ult: yields true if either operand is a QNAN or op1 is less than op2. +-- ule: yields true if either operand is a QNAN or op1 is less than or equal to op2. +-- une: yields true if either operand is a QNAN or op1 is not equal to op2. +-- uno: yields true if either operand is a QNAN. +-- true: always yields true, regardless of operands. +-- +-- LLVMs icmp knows about: +-- eq: yields true if the operands are equal, false otherwise. No sign interpretation is necessary or performed. +-- ne: yields true if the operands are unequal, false otherwise. No sign interpretation is necessary or performed. +-- ugt: interprets the operands as unsigned values and yields true if op1 is greater than op2. +-- uge: interprets the operands as unsigned values and yields true if op1 is greater than or equal to op2. +-- ult: interprets the operands as unsigned values and yields true if op1 is less than op2. +-- ule: interprets the operands as unsigned values and yields true if op1 is less than or equal to op2. +-- sgt: interprets the operands as signed values and yields true if op1 is greater than op2. +-- sge: interprets the operands as signed values and yields true if op1 is greater than or equal to op2. +-- slt: interprets the operands as signed values and yields true if op1 is less than op2. +-- sle: interprets the operands as signed values and yields true if op1 is less than or equal to op2. + +data Cond + = ALWAYS -- b.al + | EQ -- b.eq + | NE -- b.ne + -- signed + | SLT -- b.lt + | SLE -- b.le + | SGE -- b.ge + | SGT -- b.gt + -- unsigned + | ULT -- b.lo + | ULE -- b.ls + | UGE -- b.hs + | UGT -- b.hi + -- ordered + | OLT -- b.mi + | OLE -- b.ls + | OGE -- b.ge + | OGT -- b.gt + -- unordered + | UOLT -- b.lt + | UOLE -- b.le + | UOGE -- b.pl + | UOGT -- b.hi + -- others + | NEVER -- b.nv + | VS -- oVerflow set + | VC -- oVerflow clear + deriving Eq diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -0,0 +1,771 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.AArch64.Instr + +where + +import GHC.Prelude + +import GHC.CmmToAsm.AArch64.Cond +import GHC.CmmToAsm.AArch64.Regs + +import GHC.CmmToAsm.Instr (RegUsage(..)) +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.Supply + +import GHC.Utils.Panic + +import Control.Monad (replicateM) +import Data.Maybe (fromMaybe) + +import GHC.Stack + +-- | TODO: verify this! +stackFrameHeaderSize :: Platform -> Int +stackFrameHeaderSize _ = 64 + +-- | All registers are 8 byte wide. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of bytes that the stack pointer should be aligned +-- to. +stackAlign :: Int +stackAlign = 16 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config +-- = 0 -- set to zero, to see when allocMoreStack has to fire. + = let platform = ncgPlatform config + in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + `div` spillSlotSize) - 1 + +-- | Convert a spill slot number to a *byte* offset, with no sign. +spillSlotToOffset :: NCGConfig -> Int -> Int +spillSlotToOffset config slot + = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +-- RegUsage = RU [] [] + +instance Outputable RegUsage where + ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')' + +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr = case instr of + ANN _ i -> regUsageOfInstr platform i + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + CMN l r -> usage (regOp l ++ regOp r, []) + CMP 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) + 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) + + -- 2. Bit Manipulation Instructions ------------------------------------------ + SBFM dst src _ _ -> usage (regOp src, regOp dst) + UBFM dst src _ _ -> usage (regOp src, regOp dst) + SBFX dst src _ _ -> usage (regOp src, regOp dst) + UBFX dst src _ _ -> usage (regOp src, regOp dst) + SXTB dst src -> usage (regOp src, regOp dst) + UXTB dst src -> usage (regOp src, regOp dst) + SXTH dst src -> usage (regOp src, regOp dst) + UXTH 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) + BIC dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + BICS dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + EON dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + EOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + LSL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MOV dst src -> usage (regOp src, regOp dst) + MOVK dst src -> usage (regOp src, regOp dst) + MVN dst src -> usage (regOp src, regOp dst) + ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ROR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + TST src1 src2 -> usage (regOp src1 ++ regOp src2, []) + -- 4. Branch Instructions ---------------------------------------------------- + J t -> usage (regTarget t, []) + B t -> usage (regTarget t, []) + BCOND _ t -> usage (regTarget t, []) + BL t ps _rs -> usage (regTarget t ++ ps, callerSavedRegisters) + + -- 5. Atomic Instructions ---------------------------------------------------- + -- 6. Conditional Instructions ----------------------------------------------- + CSET dst _ -> usage ([], regOp dst) + CBZ src _ -> usage (regOp src, []) + CBNZ src _ -> usage (regOp src, []) + -- 7. Load and Store Instructions -------------------------------------------- + STR _ src dst -> usage (regOp src ++ regOp dst, []) + LDR _ dst src -> usage (regOp src, regOp dst) + -- TODO is this right? see STR, which I'm only partial about being right? + STP _ src1 src2 dst -> usage (regOp src1 ++ regOp src2 ++ regOp dst, []) + LDP _ dst1 dst2 src -> usage (regOp src, regOp dst1 ++ regOp dst2) + + -- 8. Synchronization Instructions ------------------------------------------- + DMBSY -> usage ([], []) + + -- 9. Floating Point Instructions -------------------------------------------- + FCVT dst src -> usage (regOp src, regOp dst) + SCVTF dst src -> usage (regOp src, regOp dst) + FCVTZS dst src -> usage (regOp src, regOp dst) + + _ -> panic "regUsageOfInstr" + + where + -- filtering the usage is necessary, otherwise the register + -- allocator will try to allocate pre-defined fixed stg + -- registers as well, as they show up. + usage (src, dst) = RU (filter (interesting platform) src) + (filter (interesting platform) dst) + + regAddr :: AddrMode -> [Reg] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrReg r1) = [r1] + regOp :: Operand -> [Reg] + regOp (OpReg _ r1) = [r1] + regOp (OpRegExt _ r1 _ _) = [r1] + regOp (OpRegShift _ r1 _ _) = [r1] + regOp (OpAddr a) = regAddr a + regOp (OpImm _) = [] + regOp (OpImmShift _ _ _) = [] + regTarget :: Target -> [Reg] + regTarget (TBlock _) = [] + regTarget (TLabel _) = [] + regTarget (TReg r1) = [r1] + + -- Is this register interesting for the register allocator? + interesting :: Platform -> Reg -> Bool + interesting _ (RegVirtual _) = True + interesting _ (RegReal (RealRegSingle (-1))) = False + interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + interesting _ (RegReal (RealRegPair{})) + = panic "AArch64.Instr.interesting: no reg pairs on this arch" + +-- Save caller save registers +-- This is x0-x18 +-- +-- For SIMD/FP Registers: +-- Registers v8-v15 must be preserved by a callee across subroutine calls; +-- the remaining registers (v0-v7, v16-v31) do not need to be preserved (or +-- should be preserved by the caller). Additionally, only the bottom 64 bits +-- of each value stored in v8-v15 need to be preserved [7]; it is the +-- responsibility of the caller to preserve larger values. +-- +-- .---------------------------------------------------------------------------------------------------------------------------------------------------------------. +-- | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | +-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | +-- |== General Purpose registers ==================================================================================================================================| +-- | <---- argument passing -------------> | IR | <------- tmp registers --------> | IP0| IP1| PL | <------------------- callee saved ------------> | FP | LR | SP | +-- | <------ free registers --------------------------------------------------------------------> | BR | Sp | Hp | R1 | R2 | R3 | R4 | R5 | R6 | SL | -- | -- | -- | +-- |== SIMD/FP Registers ==========================================================================================================================================| +-- | <---- argument passing -------------> | <-- callee saved (lower 64 bits) ---> | <--------------------------------------- caller saved ----------------------> | +-- | <------ free registers -------------> | F1 | F2 | F3 | F4 | D1 | D2 | D3 | D4 | <------ free registers -----------------------------------------------------> | +-- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' +-- 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 +callerSavedRegisters :: [Reg] +callerSavedRegisters + = map regSingle [0..18] + ++ map regSingle [32..39] + ++ map regSingle [48..63] + +-- | Apply a given mapping to all the register references in this +-- instruction. +patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr instr env = case instr of + -- 0. Meta Instructions + ANN d i -> ANN d (patchRegsOfInstr i env) + -- 1. Arithmetic Instructions ---------------------------------------------- + ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) + CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) + CMP o1 o2 -> CMP (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) + 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) + + -- 2. Bit Manipulation Instructions ---------------------------------------- + SBFM o1 o2 o3 o4 -> SBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + UBFM o1 o2 o3 o4 -> UBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + SBFX o1 o2 o3 o4 -> SBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + UBFX o1 o2 o3 o4 -> UBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + SXTB o1 o2 -> SXTB (patchOp o1) (patchOp o2) + UXTB o1 o2 -> UXTB (patchOp o1) (patchOp o2) + SXTH o1 o2 -> SXTH (patchOp o1) (patchOp o2) + UXTH o1 o2 -> UXTH (patchOp o1) (patchOp o2) + + -- 3. Logical and Move Instructions ---------------------------------------- + AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) + ANDS o1 o2 o3 -> ANDS (patchOp o1) (patchOp o2) (patchOp o3) + ASR o1 o2 o3 -> ASR (patchOp o1) (patchOp o2) (patchOp o3) + BIC o1 o2 o3 -> BIC (patchOp o1) (patchOp o2) (patchOp o3) + BICS o1 o2 o3 -> BICS (patchOp o1) (patchOp o2) (patchOp o3) + EON o1 o2 o3 -> EON (patchOp o1) (patchOp o2) (patchOp o3) + EOR o1 o2 o3 -> EOR (patchOp o1) (patchOp o2) (patchOp o3) + LSL o1 o2 o3 -> LSL (patchOp o1) (patchOp o2) (patchOp o3) + LSR o1 o2 o3 -> LSR (patchOp o1) (patchOp o2) (patchOp o3) + MOV o1 o2 -> MOV (patchOp o1) (patchOp o2) + MOVK o1 o2 -> MOVK (patchOp o1) (patchOp o2) + MVN o1 o2 -> MVN (patchOp o1) (patchOp o2) + ORR o1 o2 o3 -> ORR (patchOp o1) (patchOp o2) (patchOp o3) + ROR o1 o2 o3 -> ROR (patchOp o1) (patchOp o2) (patchOp o3) + TST o1 o2 -> TST (patchOp o1) (patchOp o2) + + -- 4. Branch Instructions -------------------------------------------------- + J t -> J (patchTarget t) + B t -> B (patchTarget t) + BL t rs ts -> BL (patchTarget t) rs ts + BCOND c t -> BCOND c (patchTarget t) + + -- 5. Atomic Instructions -------------------------------------------------- + -- 6. Conditional Instructions --------------------------------------------- + CSET o c -> CSET (patchOp o) c + CBZ o l -> CBZ (patchOp o) l + CBNZ o l -> CBNZ (patchOp o) l + -- 7. Load and Store Instructions ------------------------------------------ + STR f o1 o2 -> STR f (patchOp o1) (patchOp o2) + LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2) + STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3) + LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3) + + -- 8. Synchronization Instructions ----------------------------------------- + DMBSY -> DMBSY + + -- 9. Floating Point Instructions ------------------------------------------ + FCVT o1 o2 -> FCVT (patchOp o1) (patchOp o2) + SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) + FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) + + _ -> pprPanic "patchRegsOfInstr" (text $ show instr) + where + patchOp :: Operand -> Operand + patchOp (OpReg w r) = OpReg w (env r) + patchOp (OpRegExt w r x s) = OpRegExt w (env r) x s + patchOp (OpRegShift w r m s) = OpRegShift w (env r) m s + patchOp (OpAddr a) = OpAddr (patchAddr a) + patchOp op = op + patchTarget :: Target -> Target + patchTarget (TReg r) = TReg (env r) + patchTarget t = t + patchAddr :: AddrMode -> AddrMode + patchAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + patchAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + patchAddr (AddrReg r) = AddrReg (env r) +-------------------------------------------------------------------------------- +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +isJumpishInstr :: Instr -> Bool +isJumpishInstr instr = case instr of + ANN _ i -> isJumpishInstr i + CBZ{} -> True + CBNZ{} -> True + J{} -> True + B{} -> True + BL{} -> True + BCOND{} -> True + _ -> False + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +jumpDestsOfInstr :: Instr -> [BlockId] +jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i +jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]] +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 (BCOND _ t) = [ id | TBlock id <- [t]] +jumpDestsOfInstr _ = [] + +-- | Change the destination of this jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +patchJumpInstr instr patchF + = case instr of + ANN d i -> ANN d (patchJumpInstr i patchF) + CBZ r (TBlock bid) -> CBZ r (TBlock (patchF bid)) + 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 + BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid)) + _ -> pprPanic "patchJumpInstr" (text $ show instr) + +-- ----------------------------------------------------------------------------- +-- Note [Spills and Reloads] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading +-- registers. AArch64s maximum displacement for SP relative spills and reloads +-- is essentially [-256,255], or [0, 0xFFF]*8 = [0, 32760] for 64bits. +-- +-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't address any location in a +-- single instruction. The idea is to use the Inter Procedure 0 (ip0) register +-- to perform the computations for larger offsets. +-- +-- Using sp to compute the offset will violate assumptions about the stack pointer +-- pointing to the top of the stack during signal handling. As we can't force +-- every signal to use its own stack, we have to ensure that the stack poitner +-- always poitns to the top of the stack, and we can't use it for computation. +-- +-- | An instruction to spill a register into a spill slot. +mkSpillInstr + :: HasCallStack + => NCGConfig + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkSpillInstr config reg delta slot = + case (spillSlotToOffset config slot) - delta of + imm | -256 <= imm && imm <= 255 -> [ mkStrSp imm ] + imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff -> [ mkStrSp imm ] + imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) + , mkStrIp0 (imm .&. 0xfff) + ] + imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm) + where + a .&~. b = a .&. (complement b) + + fmt = case reg of + RegReal (RealRegSingle n) | n < 32 -> II64 + _ -> FF64 + mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm)) + mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm))) + mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm))) + + off = spillSlotToOffset config slot + +mkLoadInstr + :: NCGConfig + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkLoadInstr config reg delta slot = + case (spillSlotToOffset config slot) - delta of + imm | -256 <= imm && imm <= 255 -> [ mkLdrSp imm ] + imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff -> [ mkLdrSp imm ] + imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) + , mkLdrIp0 (imm .&. 0xfff) + ] + imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm) + where + a .&~. b = a .&. (complement b) + + fmt = case reg of + RegReal (RealRegSingle n) | n < 32 -> II64 + _ -> FF64 + + mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm)) + mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm))) + mkLdrIp0 imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm))) + + off = spillSlotToOffset config slot + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr :: Instr -> Maybe Int +takeDeltaInstr (ANN _ i) = takeDeltaInstr i +takeDeltaInstr (DELTA i) = Just i +takeDeltaInstr _ = Nothing + +-- Not real instructions. Just meta data +isMetaInstr :: Instr -> Bool +isMetaInstr instr + = case instr of + ANN _ i -> isMetaInstr i + COMMENT{} -> True + MULTILINE_COMMENT{} -> True + LOCATION{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + PUSH_STACK_FRAME -> True + POP_STACK_FRAME -> True + _ -> False + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +mkRegRegMoveInstr :: Reg -> Reg -> Instr +mkRegRegMoveInstr src dst = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src) + +-- | Take the source and destination from this reg -> reg move instruction +-- or Nothing if it's not one +takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +--takeRegRegMoveInstr (MOV (OpReg fmt dst) (OpReg fmt' src)) | fmt == fmt' = Just (src, dst) +takeRegRegMoveInstr _ = Nothing + +-- | Make an unconditional jump instruction. +mkJumpInstr :: BlockId -> [Instr] +mkJumpInstr id = [B (TBlock id)] + +mkStackAllocInstr :: Platform -> Int -> [Instr] +mkStackAllocInstr platform n + | n == 0 = [] + | n > 0 && n < 4096 = [ ANN (text "Alloc More Stack") $ SUB sp sp (OpImm (ImmInt n)) ] + | n > 0 = ANN (text "Alloc More Stack") (SUB sp sp (OpImm (ImmInt 4095))) : mkStackAllocInstr platform (n - 4095) +mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n) + +mkStackDeallocInstr :: Platform -> Int -> [Instr] +mkStackDeallocInstr platform n + | n == 0 = [] + | n > 0 && n < 4096 = [ ANN (text "Dealloc More Stack") $ ADD sp sp (OpImm (ImmInt n)) ] + | n > 0 = ANN (text "Dealloc More Stack") (ADD sp sp (OpImm (ImmInt 4095))) : mkStackDeallocInstr platform (n - 4095) +mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n) + +-- +-- See note [extra spill slots] in X86/Instr.hs +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr + -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + uniqs <- replicateM (length entries) getUniqueM + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + retargetList = (zip entries (map mkBlockId uniqs)) + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insn (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ] + , BasicBlock new_blockid block' ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + J _ -> dealloc ++ (insn : r) + ANN _ (J _) -> dealloc ++ (insn : r) + _other | jumpDestsOfInstr insn /= [] + -> patchJumpInstr insn retarget : r + _other -> insn : r + + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insn code + -- in + return (CmmProc info lbl live (ListGraph new_code), retargetList) +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +-- Some additional (potential future) instructions are commented out. They are +-- not needed yet for the backend but could be used in the future. +data Instr + -- comment pseudo-op + = COMMENT SDoc + | MULTILINE_COMMENT SDoc + + -- Annotated instruction. Should print # + | ANN SDoc Instr + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section RawCmmStatics + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for + -- benefit of subsequent passes + | DELTA Int + + -- 0. Pseudo Instructions -------------------------------------------------- + | SXTB Operand Operand + | UXTB Operand Operand + | SXTH Operand Operand + | UXTH Operand Operand + -- | SXTW Operand Operand + -- | SXTX Operand Operand + | PUSH_STACK_FRAME + | POP_STACK_FRAME + -- 1. Arithmetic Instructions ---------------------------------------------- + -- | ADC Operand Operand Operang -- rd = rn + rm + C + -- | ADCS ... + | ADD Operand Operand Operand -- rd = rn + rm + -- | ADDS Operand Operand Operand -- rd = rn + rm + -- | ADR ... + -- | ADRP ... + | CMN Operand Operand -- rd + op2 + | CMP Operand Operand -- rd - op2 + -- | MADD ... + -- | MNEG ... + | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm + | MUL Operand Operand Operand -- rd = rn × rm + | NEG Operand Operand -- rd = -op2 + -- | NEGS ... + -- | NGC ... + -- | NGCS ... + -- | SBC ... + -- | SBCS ... + | SDIV Operand Operand Operand -- rd = rn ÷ rm + -- | SMADDL ... + -- | SMNEGL ... + -- | SMSUBL ... + -- | SMULH ... + -- | SMULL ... + | SUB Operand Operand Operand -- rd = rn - op2 + -- | SUBS ... + | UDIV Operand Operand Operand -- rd = rn ÷ rm + -- | UMADDL ... -- Xd = Xa + Wn × Wm + -- | UMNEGL ... -- Xd = - Wn × Wm + -- | UMSUBL ... -- Xd = Xa - Wn × Wm + -- | UMULH ... -- Xd = (Xn × Xm)_127:64 + -- | UMULL ... -- Xd = Wn × Wm + + -- 2. Bit Manipulation Instructions ---------------------------------------- + | SBFM Operand Operand Operand Operand -- rd = rn[i,j] + -- SXTB = SBFM , , #0, #7 + -- SXTH = SBFM , , #0, #15 + -- SXTW = SBFM , , #0, #31 + | UBFM Operand Operand Operand Operand -- rd = rn[i,j] + -- UXTB = UBFM , , #0, #7 + -- UXTH = UBFM , , #0, #15 + -- Signed/Unsigned bitfield extract + | SBFX Operand Operand Operand Operand -- rd = rn[i,j] + | UBFX Operand Operand Operand Operand -- rd = rn[i,j] + + -- 3. Logical and Move Instructions ---------------------------------------- + | AND Operand Operand Operand -- rd = rn & op2 + | ANDS Operand Operand Operand -- rd = rn & op2 + | ASR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits + | BIC Operand Operand Operand -- rd = rn & ~op2 + | BICS Operand Operand Operand -- rd = rn & ~op2 + | EON Operand Operand Operand -- rd = rn ⊕ ~op2 + | EOR Operand Operand Operand -- rd = rn ⊕ op2 + | LSL Operand Operand Operand -- rd = rn ≪ rm or rd = rn ≪ #i, i is 6 bits + | LSR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits + | MOV Operand Operand -- rd = rn or rd = #i + | MOVK Operand Operand + -- | MOVN Operand Operand + -- | MOVZ Operand Operand + | MVN Operand Operand -- rd = ~rn + | ORN Operand Operand Operand -- rd = rn | ~op2 + | ORR Operand Operand Operand -- rd = rn | op2 + | ROR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits + | TST Operand Operand -- rn & op2 + -- Load and stores. + -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register. + | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr + | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr + | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8) + | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8) + + -- Conditional instructions + | CSET Operand Cond -- if(cond) op <- 1 else op <- 0 + + | CBZ Operand Target -- if op == 0, then branch. + | CBNZ Operand Target -- if op /= 0, then branch. + -- 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) + | BCOND Cond Target -- branch with condition. b. + + -- 8. Synchronization Instructions ----------------------------------------- + | DMBSY + -- 9. Floating Point Instructions + -- Float ConVerT + | FCVT Operand Operand + -- Signed ConVerT Float + | SCVTF Operand Operand + -- Float ConVerT to Zero Signed + | FCVTZS Operand Operand + +instance Show Instr where + show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2 + show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2 + show _ = "missing" + +data Target + = TBlock BlockId + | TLabel CLabel + | TReg Reg + + +-- Extension +-- {Unsigned|Signed}XT{Byte|Half|Word|Doube} +data ExtMode + = EUXTB | EUXTH | EUXTW | EUXTX + | ESXTB | ESXTH | ESXTW | ESXTX + deriving (Eq, Show) + +data ShiftMode + = SLSL | SLSR | SASR | SROR + deriving (Eq, Show) + + +-- We can also add ExtShift to Extension. +-- However at most 3bits. +type ExtShift = Int +-- at most 6bits +type RegShift = Int + +data Operand + = OpReg Width Reg -- register + | OpRegExt Width Reg ExtMode ExtShift -- rm, [, ] + | OpRegShift Width Reg ShiftMode RegShift -- rm, , <0-64> + | OpImm Imm -- immediate value + | OpImmShift Imm ShiftMode RegShift + | OpAddr AddrMode -- memory reference + deriving (Eq, Show) + +-- Smart constructors +opReg :: Width -> Reg -> Operand +opReg = OpReg + +xzr, wzr, sp, ip0 :: Operand +xzr = OpReg W64 (RegReal (RealRegSingle (-1))) +wzr = OpReg W32 (RegReal (RealRegSingle (-1))) +sp = OpReg W64 (RegReal (RealRegSingle 31)) +ip0 = OpReg W64 (RegReal (RealRegSingle 16)) + +_x :: Int -> Operand +_x i = OpReg W64 (RegReal (RealRegSingle i)) +x0, x1, x2, x3, x4, x5, x6, x7 :: Operand +x8, x9, x10, x11, x12, x13, x14, x15 :: Operand +x16, x17, x18, x19, x20, x21, x22, x23 :: Operand +x24, x25, x26, x27, x28, x29, x30, x31 :: Operand +x0 = OpReg W64 (RegReal (RealRegSingle 0)) +x1 = OpReg W64 (RegReal (RealRegSingle 1)) +x2 = OpReg W64 (RegReal (RealRegSingle 2)) +x3 = OpReg W64 (RegReal (RealRegSingle 3)) +x4 = OpReg W64 (RegReal (RealRegSingle 4)) +x5 = OpReg W64 (RegReal (RealRegSingle 5)) +x6 = OpReg W64 (RegReal (RealRegSingle 6)) +x7 = OpReg W64 (RegReal (RealRegSingle 7)) +x8 = OpReg W64 (RegReal (RealRegSingle 8)) +x9 = OpReg W64 (RegReal (RealRegSingle 9)) +x10 = OpReg W64 (RegReal (RealRegSingle 10)) +x11 = OpReg W64 (RegReal (RealRegSingle 11)) +x12 = OpReg W64 (RegReal (RealRegSingle 12)) +x13 = OpReg W64 (RegReal (RealRegSingle 13)) +x14 = OpReg W64 (RegReal (RealRegSingle 14)) +x15 = OpReg W64 (RegReal (RealRegSingle 15)) +x16 = OpReg W64 (RegReal (RealRegSingle 16)) +x17 = OpReg W64 (RegReal (RealRegSingle 17)) +x18 = OpReg W64 (RegReal (RealRegSingle 18)) +x19 = OpReg W64 (RegReal (RealRegSingle 19)) +x20 = OpReg W64 (RegReal (RealRegSingle 20)) +x21 = OpReg W64 (RegReal (RealRegSingle 21)) +x22 = OpReg W64 (RegReal (RealRegSingle 22)) +x23 = OpReg W64 (RegReal (RealRegSingle 23)) +x24 = OpReg W64 (RegReal (RealRegSingle 24)) +x25 = OpReg W64 (RegReal (RealRegSingle 25)) +x26 = OpReg W64 (RegReal (RealRegSingle 26)) +x27 = OpReg W64 (RegReal (RealRegSingle 27)) +x28 = OpReg W64 (RegReal (RealRegSingle 28)) +x29 = OpReg W64 (RegReal (RealRegSingle 29)) +x30 = OpReg W64 (RegReal (RealRegSingle 30)) +x31 = OpReg W64 (RegReal (RealRegSingle 31)) + +_d :: Int -> Operand +_d = OpReg W64 . RegReal . RealRegSingle +d0, d1, d2, d3, d4, d5, d6, d7 :: Operand +d8, d9, d10, d11, d12, d13, d14, d15 :: Operand +d16, d17, d18, d19, d20, d21, d22, d23 :: Operand +d24, d25, d26, d27, d28, d29, d30, d31 :: Operand +d0 = OpReg W64 (RegReal (RealRegSingle 32)) +d1 = OpReg W64 (RegReal (RealRegSingle 33)) +d2 = OpReg W64 (RegReal (RealRegSingle 34)) +d3 = OpReg W64 (RegReal (RealRegSingle 35)) +d4 = OpReg W64 (RegReal (RealRegSingle 36)) +d5 = OpReg W64 (RegReal (RealRegSingle 37)) +d6 = OpReg W64 (RegReal (RealRegSingle 38)) +d7 = OpReg W64 (RegReal (RealRegSingle 39)) +d8 = OpReg W64 (RegReal (RealRegSingle 40)) +d9 = OpReg W64 (RegReal (RealRegSingle 41)) +d10 = OpReg W64 (RegReal (RealRegSingle 42)) +d11 = OpReg W64 (RegReal (RealRegSingle 43)) +d12 = OpReg W64 (RegReal (RealRegSingle 44)) +d13 = OpReg W64 (RegReal (RealRegSingle 45)) +d14 = OpReg W64 (RegReal (RealRegSingle 46)) +d15 = OpReg W64 (RegReal (RealRegSingle 47)) +d16 = OpReg W64 (RegReal (RealRegSingle 48)) +d17 = OpReg W64 (RegReal (RealRegSingle 49)) +d18 = OpReg W64 (RegReal (RealRegSingle 50)) +d19 = OpReg W64 (RegReal (RealRegSingle 51)) +d20 = OpReg W64 (RegReal (RealRegSingle 52)) +d21 = OpReg W64 (RegReal (RealRegSingle 53)) +d22 = OpReg W64 (RegReal (RealRegSingle 54)) +d23 = OpReg W64 (RegReal (RealRegSingle 55)) +d24 = OpReg W64 (RegReal (RealRegSingle 56)) +d25 = OpReg W64 (RegReal (RealRegSingle 57)) +d26 = OpReg W64 (RegReal (RealRegSingle 58)) +d27 = OpReg W64 (RegReal (RealRegSingle 59)) +d28 = OpReg W64 (RegReal (RealRegSingle 60)) +d29 = OpReg W64 (RegReal (RealRegSingle 61)) +d30 = OpReg W64 (RegReal (RealRegSingle 62)) +d31 = OpReg W64 (RegReal (RealRegSingle 63)) + +opRegUExt :: Width -> Reg -> Operand +opRegUExt W64 r = OpRegExt W64 r EUXTX 0 +opRegUExt W32 r = OpRegExt W32 r EUXTW 0 +opRegUExt W16 r = OpRegExt W16 r EUXTH 0 +opRegUExt W8 r = OpRegExt W8 r EUXTB 0 +opRegUExt w _r = pprPanic "opRegUExt" (text $ show w) + +opRegSExt :: Width -> Reg -> Operand +opRegSExt W64 r = OpRegExt W64 r ESXTX 0 +opRegSExt W32 r = OpRegExt W32 r ESXTW 0 +opRegSExt W16 r = OpRegExt W16 r ESXTH 0 +opRegSExt W8 r = OpRegExt W8 r ESXTB 0 +opRegSExt w _r = pprPanic "opRegSExt" (text $ show w) diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -0,0 +1,595 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr) where + +import GHC.Prelude hiding (EQ) + +import Data.Word +import qualified Data.Array.Unsafe as U ( castSTUArray ) +import Data.Array.ST +import Control.Monad.ST + +import GHC.CmmToAsm.AArch64.Instr +import GHC.CmmToAsm.AArch64.Regs +import GHC.CmmToAsm.AArch64.Cond +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Format +import GHC.Platform.Reg +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Ppr.Expr () -- For Outputable instances + +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) +import GHC.Platform +import GHC.Utils.Outputable + +import GHC.Utils.Panic + +pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) + where + platform = ncgPlatform config + +pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in + pprProcAlignment config $$ + case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) $$ + -- do not + -- pprProcAlignment config $$ + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock config top_info) blocks) $$ + (if ncgDwarfEnabled config + then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + pprSizeDecl platform lbl + + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) $$ + -- pprProcAlignment config $$ + (if platformHasSubsectionsViaSymbols platform + then ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock config top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then -- See Note [Subsections Via Symbols] + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) $$ + pprSizeDecl platform info_lbl + +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ pprTypeDecl platform lbl + $$ (pdoc platform lbl <> char ':') + +pprAlign :: Platform -> Alignment -> SDoc +pprAlign _platform alignment + = text "\t.balign " <> int (alignmentBytes alignment) + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection _platform _seg + -- .balign is stable, whereas .align is platform dependent. + = text "\t.balign 8" -- always 8 + +instance Outputable Instr where + ppr = pprInstr genericPlatform + +-- | Print section header and appropriate alignment for that section. +-- +-- This one will emit the header: +-- +-- .section .text +-- .balign 8 +-- +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "AArch64.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec + $$ pprAlignForSection (ncgPlatform config) seg + +-- | Output the ELF .size directive. +pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl + else empty + +pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> SDoc +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ + (if ncgDwarfEnabled config + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + else empty + ) + where + -- Filter out identity moves. E.g. mov x18, x18 will be dropped. + optInstrs = filter f instrs + where f (MOV o1 o2) | o1 == o2 = False + f _ = True + + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw info_lbl info) -> + -- pprAlignForSection platform Text $$ + infoTableLoc $$ + vcat (map (pprData config) info) $$ + pprLabel platform info_lbl $$ + c $$ + (if ncgDwarfEnabled config + then ppr (mkAsmTempEndLabel info_lbl) <> char ':' + else empty) + -- Make sure the info table has the right .loc for the block + -- coming right after it. See [Note: Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr platform l + _other -> empty + +pprDatas :: NCGConfig -> RawCmmStatics -> SDoc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl (ncgPlatform config) alias + $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind') + +pprDatas config (CmmStaticsRaw lbl dats) + = vcat (pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config + +pprData :: NCGConfig -> CmmStatic -> SDoc +pprData _config (CmmString str) = pprString str +pprData _config (CmmFileEmbed path) = pprFileEmbed path + +pprData config (CmmUninitialised bytes) + = let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes + +pprData config (CmmStaticLit lit) = pprDataItem config lit + +pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = text "\t.globl " <> pdoc platform lbl + +-- Note [Always use objects for info tables] +-- See discussion in X86.Ppr +-- for why this is necessary. Essentially we need to ensure that we never +-- pass function symbols when we migth want to lookup the info table. If we +-- did, we could end up with procedure linking tables (PLT)s, and thus the +-- lookup wouldn't point to the function, but into the jump table. +-- +-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as +-- well. +pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable then + text "@function" + else + text "@object" + where + functionOkInfoTable = platformTablesNextToCode platform && + isInfoTableLabel lbl && not (isConInfoTableLabel lbl) + +-- this is called pprTypeAndSizeDecl in PPC.Ppr +pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl + else empty + +pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem config lit + = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + platform = ncgPlatform config + + imm = litToImm lit + + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprImm platform imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs + + ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) + +floatToBytes :: Float -> [Int] +floatToBytes f + = runST (do + arr <- newArray_ ((0::Int),3) + writeArray arr 0 f + arr <- castFloatToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + return (map fromIntegral [i0,i1,i2,i3]) + ) + +castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) +castFloatToWord8Array = U.castSTUArray + +pprImm :: Platform -> Imm -> SDoc +pprImm _ (ImmInt i) = int i +pprImm _ (ImmInteger i) = integer i +pprImm p (ImmCLbl l) = pdoc p l +pprImm p (ImmIndex l i) = pdoc p l <> char '+' <> int i +pprImm _ (ImmLit s) = s + +-- TODO: See pprIm below for why this is a bad idea! +pprImm _ (ImmFloat f) + | f == 0 = text "wzr" + | otherwise = float (fromRational f) +pprImm _ (ImmDouble d) + | d == 0 = text "xzr" + | otherwise = double (fromRational d) + +pprImm p (ImmConstantSum a b) = pprImm p a <> char '+' <> pprImm p b +pprImm p (ImmConstantDiff a b) = pprImm p a <> char '-' + <> lparen <> pprImm p b <> rparen + + +-- aarch64 GNU as uses // for comments. +asmComment :: SDoc -> SDoc +asmComment c = whenPprDebug $ text "#" <+> c + +asmDoubleslashComment :: SDoc -> SDoc +asmDoubleslashComment c = whenPprDebug $ text "//" <+> c + +asmMultilineComment :: SDoc -> SDoc +asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/" + +pprIm :: Platform -> Imm -> SDoc +pprIm platform im = case im of + ImmInt i -> char '#' <> int i + ImmInteger i -> char '#' <> integer i + + -- TODO: This will only work for + -- The floating point value must be expressable as ±n ÷ 16 × 2^r, + -- where n and r are integers such that 16 ≤ n ≤ 31 and -3 ≤ r ≤ 4. + -- and 0 needs to be encoded as wzr/xzr. + -- + -- Except for 0, we might want to either split it up into enough + -- ADD operations into an Integer register and then just bit copy it into + -- the double register? See the toBytes + fromRational above for data items. + -- This is something the x86 backend does. + -- + -- We could also just turn them into statics :-/ Which is what the + -- PowerPC backend odes. + ImmFloat f | f == 0 -> text "wzr" + ImmFloat f -> char '#' <> float (fromRational f) + ImmDouble d | d == 0 -> text "xzr" + ImmDouble d -> char '#' <> double (fromRational d) + -- = pseudo instruction! + ImmCLbl l -> char '=' <> pdoc platform l + ImmIndex l o -> text "[=" <> pdoc platform l <> comma <+> char '#' <> int o <> char ']' + _ -> panic "AArch64.pprIm" + +pprExt :: ExtMode -> SDoc +pprExt EUXTB = text "uxtb" +pprExt EUXTH = text "uxth" +pprExt EUXTW = text "uxtw" +pprExt EUXTX = text "uxtx" +pprExt ESXTB = text "sxtb" +pprExt ESXTH = text "sxth" +pprExt ESXTW = text "sxtw" +pprExt ESXTX = text "sxtx" + +pprShift :: ShiftMode -> SDoc +pprShift SLSL = text "lsl" +pprShift SLSR = text "lsr" +pprShift SASR = text "asr" +pprShift SROR = text "ror" + +pprOp :: Platform -> Operand -> SDoc +pprOp plat op = case op of + OpReg w r -> pprReg w r + OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x + OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i + OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <> comma <+> char '#' <> int i + OpImm im -> pprIm plat im + OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i + -- TODO: Address compuation always use registers as 64bit -- is this correct? + OpAddr (AddrRegReg r1 r2) -> char '[' <+> pprReg W64 r1 <> comma <+> pprReg W64 r2 <+> char ']' + OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']' + OpAddr (AddrReg r1) -> char '[' <+> pprReg W64 r1 <+> char ']' + +pprReg :: Width -> Reg -> SDoc +pprReg w r = case r of + RegReal (RealRegSingle i) -> ppr_reg_no w i + RegReal (RealRegPair{}) -> panic "AArch64.pprReg: no reg pairs on this arch!" + -- virtual regs should not show up, but this is helpful for debugging. + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + _ -> pprPanic "AArch64.pprReg" (text $ show r) + + where + ppr_reg_no :: Width -> Int -> SDoc + ppr_reg_no w 31 + | w == W64 = text "sp" + | w == W32 = text "wsp" + + ppr_reg_no w i + | i < 0, w == W32 = text "wzr" + | i < 0, w == W64 = text "xzr" + | i < 0 = pprPanic "Invalid Zero Reg" (ppr w <+> int i) + -- General Purpose Registers + | i <= 31, w == W8 = text "w" <> int i -- there are no byte or half + | i <= 31, w == W16 = text "w" <> int i -- words... word will do. + | i <= 31, w == W32 = text "w" <> int i + | i <= 31, w == W64 = text "x" <> int i + | i <= 31 = pprPanic "Invalid Reg" (ppr w <+> int i) + -- Floating Point Registers + | i <= 63, w == W8 = text "b" <> int (i-32) + | i <= 63, w == W16 = text "h" <> int (i-32) + | i <= 63, w == W32 = text "s" <> int (i-32) + | i <= 63, w == W64 = text "d" <> int (i-32) + -- no support for 'q'uad in GHC's NCG yet. + | otherwise = text "very naughty powerpc register" + +isFloatOp :: Operand -> Bool +isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True +isFloatOp (OpReg _ (RegVirtual (VirtualRegF _))) = True +isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True +isFloatOp _ = False + +pprInstr :: Platform -> Instr -> SDoc +pprInstr platform instr = case instr of + -- Meta Instructions --------------------------------------------------------- + COMMENT s -> asmComment s + MULTILINE_COMMENT s -> asmMultilineComment s + ANN d i -> pprInstr platform i <+> asmDoubleslashComment d + LOCATION file line col _name + -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col + DELTA d -> asmComment $ text ("\tdelta = " ++ show d) + NEWBLOCK _ -> panic "PprInstr: NEWBLOCK" + LDATA _ _ -> panic "pprInstr: LDATA" + + -- Pseudo Instructions ------------------------------------------------------- + + PUSH_STACK_FRAME -> text "\tstp x29, x30, [sp, #-16]!" + $$ text "\tmov x29, sp" + + POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16" + -- =========================================================================== + -- AArch64 Instruction Set + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfadd" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + | otherwise -> text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + CMN o1 o2 -> text "\tcmn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + CMP o1 o2 + | isFloatOp o1 && isFloatOp o2 -> text "\tfcmp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | otherwise -> text "\tcmp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + MSUB o1 o2 o3 o4 -> text "\tmsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + MUL o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfmul" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + | otherwise -> text "\tmul" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + NEG o1 o2 + | isFloatOp o1 && isFloatOp o2 -> text "\tfneg" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | otherwise -> text "\tneg" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + SDIV o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 + -> text "\tfdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + SDIV o1 o2 o3 -> text "\tsdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + + SUB o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + | otherwise -> text "\tsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + UDIV o1 o2 o3 -> text "\tudiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + + -- 2. Bit Manipulation Instructions ------------------------------------------ + SBFM o1 o2 o3 o4 -> text "\tsbfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + UBFM o1 o2 o3 o4 -> text "\tubfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + -- signed and unsigned bitfield extract + SBFX o1 o2 o3 o4 -> text "\tsbfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + UBFX o1 o2 o3 o4 -> text "\tubfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + SXTB o1 o2 -> text "\tsxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + UXTB o1 o2 -> text "\tuxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + SXTH o1 o2 -> text "\tsxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + UXTH o1 o2 -> text "\tuxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + + -- 3. Logical and Move Instructions ------------------------------------------ + AND o1 o2 o3 -> text "\tand" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + ANDS o1 o2 o3 -> text "\tands" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + ASR o1 o2 o3 -> text "\tasr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + BIC o1 o2 o3 -> text "\tbic" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + BICS o1 o2 o3 -> text "\tbics" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + EON o1 o2 o3 -> text "\teon" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + EOR o1 o2 o3 -> text "\teor" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + LSL o1 o2 o3 -> text "\tlsl" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + LSR o1 o2 o3 -> text "\tlsr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + MOV o1 o2 + | isFloatOp o1 || isFloatOp o2 -> text "\tfmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | otherwise -> text "\tmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + MOVK o1 o2 -> text "\tmovk" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + MVN o1 o2 -> text "\tmvn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + ORN o1 o2 o3 -> text "\torn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + ORR o1 o2 o3 -> text "\torr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + ROR o1 o2 o3 -> text "\tror" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + TST o1 o2 -> text "\ttst" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + + -- 4. Branch Instructions ---------------------------------------------------- + J t -> pprInstr platform (B t) + B (TBlock bid) -> text "\tb" <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) + B (TLabel lbl) -> text "\tb" <+> pdoc platform lbl + B (TReg r) -> text "\tbr" <+> pprReg W64 r + + BL (TBlock bid) _ _ -> text "\tbl" <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ _ -> text "\tbl" <+> pdoc platform lbl + BL (TReg r) _ _ -> text "\tblr" <+> pprReg W64 r + + BCOND c (TBlock bid) -> text "\t" <> pprBcond c <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) + BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pdoc platform lbl + BCOND _ (TReg _) -> panic "AArch64.ppr: No conditional branching to registers!" + + -- 5. Atomic Instructions ---------------------------------------------------- + -- 6. Conditional Instructions ----------------------------------------------- + CSET o c -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c + + CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) + CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform lbl + CBZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!" + + CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) + CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform lbl + CBNZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!" + + -- 7. Load and Store Instructions -------------------------------------------- + -- NOTE: GHC may do whacky things where it only load the lower part of an + -- address. Not observing the correct size when loading will lead + -- inevitably to crashes. + STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> + text "\tstrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> + text "\tstrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + STR _f o1 o2 -> text "\tstr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + +#if defined(darwin_HOST_OS) + LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + + LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + + LDR _f o1 (OpImm (ImmIndex lbl off)) -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + + LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" + + LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" + + LDR _f o1 (OpImm (ImmCLbl lbl)) -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" +#else + LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + + LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + + LDR _f o1 (OpImm (ImmIndex lbl off)) -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + + LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" + + LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ + text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" + + LDR _f o1 (OpImm (ImmCLbl lbl)) -> + text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$ + text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl +#endif + + LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> + text "\tldrsb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> + text "\tldrsh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + LDR _f o1 o2 -> text "\tldr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + + STP _f o1 o2 o3 -> text "\tstp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + LDP _f o1 o2 o3 -> text "\tldp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + + -- 8. Synchronization Instructions ------------------------------------------- + DMBSY -> text "\tdmb sy" + -- 8. Synchronization Instructions ------------------------------------------- + FCVT o1 o2 -> text "\tfcvt" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + SCVTF o1 o2 -> text "\tscvtf" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + FCVTZS o1 o2 -> text "\tfcvtzs" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + +pprBcond :: Cond -> SDoc +pprBcond c = text "b." <> pprCond c + +pprCond :: Cond -> SDoc +pprCond c = case c of + ALWAYS -> text "al" -- Always + EQ -> text "eq" -- Equal + NE -> text "ne" -- Not Equal + + SLT -> text "lt" -- Signed less than ; Less than, or unordered + SLE -> text "le" -- Signed less than or equal ; Less than or equal, or unordered + SGE -> text "ge" -- Signed greater than or equal ; Greater than or equal + SGT -> text "gt" -- Signed greater than ; Greater than + + ULT -> text "lo" -- Carry clear/ unsigned lower ; less than + ULE -> text "ls" -- Unsigned lower or same ; Less than or equal + UGE -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered + UGT -> text "hi" -- Unsigned higher ; Greater than, or unordered + + NEVER -> text "nv" -- Never + VS -> text "vs" -- Overflow ; Unordered (at least one NaN operand) + VC -> text "vc" -- No overflow ; Not unordered + + -- Orderd variants. Respecting NaN. + OLT -> text "mi" + OLE -> text "ls" + OGE -> text "ge" + OGT -> text "gt" + + -- Unordered + UOLT -> text "lt" + UOLE -> text "le" + UOGE -> text "pl" + UOGT -> text "hi" diff --git a/compiler/GHC/CmmToAsm/AArch64/RegInfo.hs b/compiler/GHC/CmmToAsm/AArch64/RegInfo.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64/RegInfo.hs @@ -0,0 +1,31 @@ +module GHC.CmmToAsm.AArch64.RegInfo where + +import GHC.Prelude + +import GHC.CmmToAsm.AArch64.Instr +import GHC.Cmm.BlockId +import GHC.Cmm + +import GHC.Utils.Outputable + +data JumpDest = DestBlockId BlockId + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +-- TODO: documen what this does. See Ticket 19914 +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +-- TODO: document what this does. See Ticket 19914 +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +-- TODO: document what this does. See Ticket 19914 +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics _ other_static = other_static + +-- TODO: document what this does. See Ticket 19914 +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -0,0 +1,167 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.CmmToAsm.AArch64.Regs where + +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.CmmToAsm.Format + +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Types.Unique + +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +allMachRegNos :: [RegNo] +allMachRegNos = [0..31] ++ [32..63] +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = freeReg platform i + in map RealRegSingle $ filter isFree allMachRegNos + + +-- argRegs is the set of regs which are read for an n-argument call to C. +allGpArgRegs :: [Reg] +allGpArgRegs = map regSingle [0..7] +allFpArgRegs :: [Reg] +allFpArgRegs = map regSingle [32..39] + +-- STG: +-- 19: Base +-- 20: Sp +-- 21: Hp +-- 22-27: R1-R6 +-- 28: SpLim + +-- This is the STG Sp reg. +-- sp :: Reg +-- sp = regSingle 20 + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + | AddrReg Reg + deriving (Eq, Show) + +-- ----------------------------------------------------------------------------- +-- Immediates + +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit SDoc -- Simple string + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + deriving (Eq, Show) + +instance Show SDoc where + show = showPprUnsafe . ppr + +instance Eq SDoc where + lhs == rhs = show lhs == show rhs + +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "AArch64.Regs.litToImm: no match" + + +-- == To satisfy GHC.CmmToAsm.Reg.Target ======================================= + +-- squeese functions for the graph allocator ----------------------------------- +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcDouble + -> case vr of + VirtualRegD{} -> 1 + VirtualRegF{} -> 0 + _other -> 0 + + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 1 -- first fp reg is 32 + | otherwise -> 0 + + RealRegPair{} -> 0 + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 0 + | otherwise -> 1 + + RealRegPair{} -> 0 + + _other -> 0 + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise + = case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "AArch64.mkVirtualReg" + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | otherwise = RcDouble + +classOfRealReg (RealRegPair{}) + = panic "regClass(ppr): no reg pairs on this architecture" + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + RcDouble -> text "green" 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 @@ -15,7 +15,7 @@ import GHC.Prelude -import GHC.Driver.Ppr (pprTrace) +import GHC.Platform import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad @@ -23,30 +23,26 @@ import GHC.CmmToAsm.Types import GHC.CmmToAsm.Config -import GHC.Cmm.BlockId import GHC.Cmm +import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Platform import GHC.Types.Unique.FM import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Data.List.SetOps (removeDups) +import GHC.Data.OrdList + +import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Data.Maybe --- DEBUGGING ONLY ---import GHC.Cmm.DebugBlock ---import Debug.Trace -import GHC.Data.List.SetOps (removeDups) - -import GHC.Data.OrdList import Data.List (sortOn, sortBy) import Data.Foldable (toList) - import qualified Data.Set as Set import Data.STRef import Control.Monad.ST.Strict diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs --- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs @@ -216,6 +216,7 @@ | r == xmm14 -> 31 | r == xmm15 -> 32 ArchPPC_64 _ -> fromIntegral $ toRegNo r + ArchAArch64 -> fromIntegral $ toRegNo r _other -> error "dwarfRegNo: Unsupported platform or unknown register!" -- | Virtual register number to use for return address. @@ -228,4 +229,5 @@ ArchX86 -> 8 -- eip ArchX86_64 -> 16 -- rip ArchPPC_64 ELF_V2 -> 65 -- lr (link register) + ArchAArch64-> 30 _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -44,7 +44,7 @@ import GHC.CmmToAsm.Dwarf.Constants import qualified Data.ByteString as BS -import qualified Control.Monad.Trans.State.Strict as S +import qualified GHC.Utils.Monad.State.Strict as S import Control.Monad (zipWithM, join) import qualified Data.Map as Map import Data.Word diff --git a/compiler/GHC/CmmToAsm/Format.hs b/compiler/GHC/CmmToAsm/Format.hs --- a/compiler/GHC/CmmToAsm/Format.hs +++ b/compiler/GHC/CmmToAsm/Format.hs @@ -12,6 +12,7 @@ Format(..), intFormat, floatFormat, + isIntFormat, isFloatFormat, cmmTypeFormat, formatToWidth, @@ -73,6 +74,9 @@ other -> pprPanic "Format.floatFormat" (ppr other) +-- | Check if a format represent an integer value. +isIntFormat :: Format -> Bool +isIntFormat = not . isFloatFormat -- | Check if a format represents a floating point value. isFloatFormat :: Format -> Bool 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 @@ -31,6 +31,7 @@ reads :: [Reg], writes :: [Reg] } + deriving Show -- | No regs read or written to. noUsage :: RegUsage @@ -90,7 +91,7 @@ -> Reg -- ^ the reg to spill -> Int -- ^ the current stack delta -> Int -- ^ spill slot to use - -> instr + -> [instr] -- ^ instructions -- | An instruction to reload a register from a spill slot. @@ -99,7 +100,7 @@ -> Reg -- ^ the reg to reload. -> Int -- ^ the current stack delta -> Int -- ^ the spill slot to use - -> instr + -> [instr] -- ^ instructions -- | See if this instruction is telling us the current C stack delta takeDeltaInstr @@ -157,3 +158,6 @@ -- | Pretty-print an instruction pprInstr :: Platform -> instr -> SDoc + + -- Create a comment instruction + mkComment :: SDoc -> [instr] diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -122,6 +122,15 @@ addImport stub return $ CmmLit $ CmmLabel stub + -- GOT relative loads work differently on AArch64. We don't do two + -- step loads. The got symbol is loaded directly, and not through an + -- additional load. Thus we do not need the CmmLoad decoration we have + -- on other platforms. + AccessViaSymbolPtr | ArchAArch64 <- platformArch platform -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmMakePicReference config symbolPtr + AccessViaSymbolPtr -> do let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl addImport symbolPtr @@ -135,7 +144,6 @@ -- so just jump there if it's a call or a jump _ -> return $ CmmLit $ CmmLabel lbl - -- ----------------------------------------------------------------------------- -- Create a position independent reference to a label. -- (but do not bother with dynamic linking). @@ -150,6 +158,11 @@ | OSMinGW32 <- platformOS platform = CmmLit $ CmmLabel lbl + -- no pic base reg on AArch64, however indicate this symbol should go through + -- the global offset table (GOT). + | ArchAArch64 <- platformArch platform + = CmmLit $ CmmLabel lbl + | OSAIX <- platformOS platform = CmmMachOp (MO_Add W32) [ CmmReg (CmmGlobal PicBaseReg) @@ -241,7 +254,21 @@ | otherwise = AccessDirectly +-- On AArch64, relocations for JUMP and CALL will be emitted with 26bits, this +-- is enough for ~64MB of range. Anything else will need to go through a veneer, +-- which is the job of the linker to build. We might only want to lookup +-- Data References through the GOT. +howToAccessLabel config ArchAArch64 _os _kind lbl + | not (ncgExternalDynamicRefs config) + = AccessDirectly + | labelDynamic config lbl + = AccessViaSymbolPtr + + | otherwise + = AccessDirectly + + -- Mach-O (Darwin, Mac OS X) -- -- Indirect access is required in the following cases: @@ -275,7 +302,7 @@ -- dyld code stubs don't work for tailcalls because the -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: - | arch == ArchX86 || arch == ArchX86_64 + | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64 , labelDynamic config lbl = AccessViaSymbolPtr @@ -283,15 +310,15 @@ howToAccessLabel config arch OSDarwin _kind lbl -- Code stubs are the usual method of choice for imported code; -- not needed on x86_64 because Apple's new linker, ld64, generates - -- them automatically. + -- them automatically, neither on Aarch64 (arm64). | arch /= ArchX86_64 + , arch /= ArchAArch64 , labelDynamic config lbl = AccessViaStub | otherwise = AccessDirectly - ---------------------------------------------------------------------------- -- AIX @@ -616,7 +643,9 @@ | otherwise -> empty - (_, OSDarwin) -> empty + (ArchAArch64, OSDarwin) + -> empty + -- XCOFF / AIX 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 @@ -57,5 +57,4 @@ mkStackAllocInstr = PPC.mkStackAllocInstr mkStackDeallocInstr = PPC.mkStackDeallocInstr pprInstr = PPC.pprInstr - - + mkComment = const [] 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 @@ -533,7 +533,7 @@ -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use - -> Instr + -> [Instr] mkSpillInstr config reg delta slot = let platform = ncgPlatform config @@ -550,7 +550,7 @@ Just _ -> ST Nothing -> STFAR -- pseudo instruction: 32 bit offsets - in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) + in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))] mkLoadInstr @@ -558,7 +558,7 @@ -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use - -> Instr + -> [Instr] mkLoadInstr config reg delta slot = let platform = ncgPlatform config @@ -575,7 +575,7 @@ Just _ -> LD Nothing -> LDFAR -- pseudo instruction: 32 bit offsets - in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) + in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))] -- | The size of a minimal stackframe header including minimal diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -18,7 +18,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Utils.Monad -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -45,7 +45,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Builtin.Uniques -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -33,7 +33,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict import GHC.CmmToAsm.CFG import Data.List (nub, minimumBy) diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -38,7 +38,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Outputable -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict -- | Holds interesting statistics from the register allocator. data RegAllocStats statics instr 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 @@ -111,7 +111,10 @@ ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 15 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> panic "trivColorable ArchAArch64" + -- We should be able to allocate *a lot* more in princple. + -- essentially all 32 - SP, so 31, we'd trash the link reg + -- as well as the platform and all others though. + ArchAArch64 -> 18 ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" @@ -143,7 +146,10 @@ ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 0 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> panic "trivColorable ArchAArch64" + -- we can in princple address all the float regs as + -- segments. So we could have 64 Float regs. Or + -- 128 Half regs, or even 256 Byte regs. + ArchAArch64 -> 0 ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" @@ -177,7 +183,7 @@ ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> panic "trivColorable ArchAArch64" + ArchAArch64 -> 32 ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -110,10 +110,11 @@ import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.JoinToTargets -import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC -import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC -import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 -import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC +import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC +import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 +import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Utils @@ -121,6 +122,7 @@ import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types import GHC.Platform.Reg +import GHC.Platform.Reg.Class (RegClass(..)) import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections @@ -202,7 +204,7 @@ -- an entry in the block map or it is the first block. -- linearRegAlloc - :: forall instr. Instruction instr + :: forall instr. (Instruction instr) => NCGConfig -> [BlockId] -- ^ entry points -> BlockMap RegSet @@ -220,7 +222,7 @@ ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchAArch64 -> panic "linearRegAlloc ArchAArch64" + ArchAArch64 -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs) ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) ArchAlpha -> panic "linearRegAlloc ArchAlpha" ArchMipseb -> panic "linearRegAlloc ArchMipseb" @@ -487,7 +489,7 @@ genRaInsn :: forall freeRegs instr. - OutputableRegConstraint freeRegs instr + (OutputableRegConstraint freeRegs instr) => BlockMap RegSet -> [instr] -> BlockId @@ -497,7 +499,7 @@ -> RegM freeRegs ([instr], [NatBasicBlock instr]) genRaInsn block_live new_instrs block_id instr r_dying w_dying = do --- pprTraceM "genRaInsn" $ ppr (block_id, instr) +-- pprTraceM "genRaInsn" $ ppr (block_id, instr) platform <- getPlatform case regUsageOfInstr platform instr of { RU read written -> do @@ -509,20 +511,21 @@ -- so using nub isn't a problem). let virt_read = nub [ vr | (RegVirtual vr) <- read ] :: [VirtualReg] - -- debugging -{- freeregs <- getFreeRegsR - assig <- getAssigR - pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn" - (ppr instr - $$ text "r_dying = " <+> ppr r_dying - $$ text "w_dying = " <+> ppr w_dying - $$ text "virt_read = " <+> ppr virt_read - $$ text "virt_written = " <+> ppr virt_written - $$ text "freeregs = " <+> text (show freeregs) - $$ text "assig = " <+> ppr assig) - $ do --} +-- do +-- let real_read = nub [ rr | (RegReal rr) <- read] +-- freeregs <- getFreeRegsR +-- assig <- getAssigR +-- pprTraceM "genRaInsn" +-- ( text "block = " <+> ppr block_id +-- $$ text "instruction = " <+> ppr instr +-- $$ text "r_dying = " <+> ppr r_dying +-- $$ text "w_dying = " <+> ppr w_dying +-- $$ text "read = " <+> ppr real_read <+> ppr virt_read +-- $$ text "written = " <+> ppr real_written <+> ppr virt_written +-- $$ text "freeregs = " <+> ppr freeregs +-- $$ text "assign = " <+> ppr assig) + -- (a), (b) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read @@ -580,7 +583,6 @@ Nothing -> x Just y -> y - -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) @@ -592,8 +594,33 @@ | src == dst -> [] _ -> [patched_instr] - let code = concat [ squashed_instr, w_spills, reverse r_spills, clobber_saves, new_instrs ] + -- On the use of @reverse@ below. + -- Since we can have spills and reloads produce multiple instructions + -- we need to ensure they are emitted in the correct order. We used to only + -- emit single instructions in mkSpill/mkReload/mkRegRegMove. + -- As such order of spills and reloads didn't matter. However, with + -- mutliple instructions potentially issued by those functions we need to be + -- careful to not break execution order. Reversing the spills (clobber will + -- also spill), will ensure they are emitted in the right order. + -- + -- See also Ticket 19910 for changing the return type from [] to OrdList. + -- For debugging, uncomment the follow line and the mkComment lines. + -- u <- getUniqueR + let code = concat [ -- mkComment (text " ppr u <> text ")>") + -- ,mkComment (text " ppr u <> text "):squashed>")] + squashed_instr + -- ,mkComment (text " ppr u <> text "):w_spills>") + , reverse w_spills + -- ,mkComment (text " ppr u <> text "):r_spills>") + , reverse r_spills + -- ,mkComment (text " ppr u <> text "):clobber_saves>") + , reverse clobber_saves + -- ,mkComment (text " ppr u <> text "):new_instrs>") + , new_instrs + -- ,mkComment (text " ppr u <> text ")>") + ] + -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do @@ -609,6 +636,7 @@ platform <- getPlatform assig <- getAssigR free <- getFreeRegsR + let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs loop assig !free (r:rs) = @@ -662,8 +690,9 @@ (instrs,assig') <- clobber assig [] to_spill setAssigR assig' - return instrs - + return $ -- mkComment (text "") ++ + instrs +-- ++ mkComment (text "") where -- See Note [UniqFM and the register allocator] clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc) @@ -700,7 +729,7 @@ let new_assign = addToUFM_Directly assig temp (InBoth reg slot) - clobber new_assign (spill : instrs) rest + clobber new_assign (spill ++ instrs) rest @@ -714,8 +743,18 @@ clobberRegs clobbered = do platform <- getPlatform freeregs <- getFreeRegsR - setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered + let gpRegs = frGetFreeRegs platform RcInteger freeregs :: [RealReg] + fltRegs = frGetFreeRegs platform RcFloat freeregs :: [RealReg] + dblRegs = frGetFreeRegs platform RcDouble freeregs :: [RealReg] + + let extra_clobbered = [ r | r <- clobbered + , r `elem` (gpRegs ++ fltRegs ++ dblRegs) ] + + setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered + + -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered + assig <- getAssigR setAssigR $! clobber assig (nonDetUFMToList assig) -- This is non-deterministic but we do not @@ -909,10 +948,7 @@ | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ -- COMMENT (fsLit "spill alloc") - spill_insn ] + (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out -- record that this temp was spilled recordSpill (SpillAlloc temp_to_push_out) @@ -962,7 +998,7 @@ = do insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) - return $ {- COMMENT (fsLit "spill load") : -} insn : spills + return $ {- mkComment (text "spill load") : -} insn ++ spills loadTemp _ _ _ spills = return spills diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs @@ -0,0 +1,137 @@ +module GHC.CmmToAsm.Reg.Linear.AArch64 where + +import GHC.Prelude + +import GHC.CmmToAsm.AArch64.Regs +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Platform + +import Data.Word + +import GHC.Stack +-- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp +-- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON +-- extension in Armv8-A. +-- +-- Armv8-A is a fundamental change to the Arm architecture. It supports the +-- 64-bit Execution state called “AArch64”, and a new 64-bit instruction set +-- “A64”. To provide compatibility with the Armv7-A (32-bit architecture) +-- instruction set, a 32-bit variant of Armv8-A “AArch32” is provided. Most of +-- existing Armv7-A code can be run in the AArch32 execution state of Armv8-A. +-- +-- these can be addresses as q/d/s/h/b 0..31, or v.f[idx] +-- where size is 64, 32, 16, 8, ... and the index i allows us +-- to access the given part. +-- +-- History of Arm Adv SIMD +-- .---------------------------------------------------------------------------. +-- | Armv6 | Armv7-A | Armv8-A AArch64 | +-- | SIMD extension | NEON | NEON | +-- |===========================================================================| +-- | - Operates on 32-bit | - Separate reg. bank, | - Separate reg. bank, | +-- | GP ARM registers | 32x64-bit NEON regs | 32x128-bit NEON regs | +-- | - 8-bit/16-bit integer | - 8/16/32/64-bit int | - 8/16/32/64-bit int | +-- | | - Single percision fp | - Single percision fp | +-- | | | - Double precision fp | +-- | | | - Single/Double fp are | +-- | | | IEEE compliant | +-- | - 2x16-bit/4x8-bit ops | - Up to 16x8-bit ops | - Up to 16x8-bit ops | +-- | per instruction | per instruction | per instruction | +-- '---------------------------------------------------------------------------' + +data FreeRegs = FreeRegs !Word32 !Word32 + +instance Show FreeRegs where + show (FreeRegs g f) = "FreeRegs: " ++ showBits g ++ "; " ++ showBits f + +instance Outputable FreeRegs where + ppr (FreeRegs g f) = text " " <+> foldr (\i x -> pad_int i <+> x) (text "") [0..31] + $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0..31] + $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0..31] + where pad_int i | i < 10 = char ' ' <> int i + pad_int i = int i + -- remember bit = 1 means it's available. + show_bit bits bit | testBit bits bit = text " " + show_bit _ _ = text " x" + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +showBits :: Word32 -> String +showBits w = map (\i -> if testBit w i then '1' else '0') [0..31] + +-- FR instance implementation (See Linear.FreeRegs) +allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) + | r < 32 && testBit g r = FreeRegs (clearBit g r) f + | r > 31 = panic $ "Linear.AArch64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f + | otherwise = pprPanic "Linear.AArch64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g) +allocateReg _ _ = panic "Linear.AArch64.allocReg: bad reg" + +-- we start from 28 downwards... the logic is similar to the ppc logic. +-- 31 is Stack Pointer +-- 30 is Link Register +-- 29 is Stack Frame (by convention) +-- 19-28 are callee save +-- the lower ones are all caller save + +-- For this reason someone decided to give aarch64 only 6 regs for +-- STG: +-- 19: Base +-- 20: Sp +-- 21: Hp +-- 22-27: R1-R6 +-- 28: SpLim + +-- For LLVM code gen interop: +-- See https://lists.llvm.org/pipermail/llvm-commits/Week-of-Mon-20150119/253722.html +-- and the current ghccc implementation here: +-- https://github.com/llvm/llvm-project/blob/161ae1f39816edf667aaa190bce702a86879c7bd/llvm/lib/Target/AArch64/AArch64CallingConvention.td#L324-L363 +-- and https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/generated-code +-- for the STG discussion. +{- For reference the ghcc from the link above: +let Entry = 1 in +def CC_AArch64_GHC : CallingConv<[ + CCIfType<[iPTR], CCBitConvertToType>, + + // Handle all vector types as either f64 or v2f64. + CCIfType<[v1i64, v2i32, v4i16, v8i8, v2f32], CCBitConvertToType>, + CCIfType<[v2i64, v4i32, v8i16, v16i8, v4f32, f128], CCBitConvertToType>, + + CCIfType<[v2f64], CCAssignToReg<[Q4, Q5]>>, + CCIfType<[f32], CCAssignToReg<[S8, S9, S10, S11]>>, + CCIfType<[f64], CCAssignToReg<[D12, D13, D14, D15]>>, + + // Promote i8/i16/i32 arguments to i64. + CCIfType<[i8, i16, i32], CCPromoteToType>, + + // Pass in STG registers: Base, Sp, Hp, R1, R2, R3, R4, R5, R6, SpLim + CCIfType<[i64], CCAssignToReg<[X19, X20, X21, X22, X23, X24, X25, X26, X27, X28]>> +]>; +-} + +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] +getFreeRegs cls (FreeRegs g f) + | RcFloat <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted. + | RcDouble <- cls = go 32 f 31 + | RcInteger <- cls = go 0 g 18 + where + go _ _ i | i < 0 = [] + go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1) + | otherwise = go off x $! i - 1 + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) + | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r) + | r > 31 = FreeRegs g (setBit f (r - 32)) + | otherwise = FreeRegs (setBit g r) f +releaseReg _ _ = pprPanic "Linear.AArch64.releaseReg" (text "bad reg") diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -25,14 +25,16 @@ -- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f -- allocateReg f r = filter (/= r) f -import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC -import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC -import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 -import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC +import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC +import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 +import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 -import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr -import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr -import qualified GHC.CmmToAsm.X86.Instr as X86.Instr +import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr +import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr +import qualified GHC.CmmToAsm.X86.Instr as X86.Instr +import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr class Show freeRegs => FR freeRegs where frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs @@ -58,6 +60,12 @@ frInitFreeRegs = PPC.initFreeRegs frReleaseReg = \_ -> PPC.releaseReg +instance FR AArch64.FreeRegs where + frAllocateReg = \_ -> AArch64.allocateReg + frGetFreeRegs = \_ -> AArch64.getFreeRegs + frInitFreeRegs = AArch64.initFreeRegs + frReleaseReg = \_ -> AArch64.releaseReg + instance FR SPARC.FreeRegs where frAllocateReg = SPARC.allocateReg frGetFreeRegs = \_ -> SPARC.getFreeRegs @@ -73,7 +81,7 @@ ArchSPARC -> SPARC.Instr.maxSpillSlots config ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" - ArchAArch64 -> panic "maxSpillSlots ArchAArch64" + ArchAArch64 -> AArch64.Instr.maxSpillSlots config ArchPPC_64 _ -> PPC.Instr.maxSpillSlots config ArchAlpha -> panic "maxSpillSlots ArchAlpha" ArchMipseb -> panic "maxSpillSlots ArchMipseb" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -26,6 +26,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Data.Graph.Directed import GHC.Utils.Panic +import GHC.Utils.Monad (concatMapM) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set @@ -306,7 +307,7 @@ -- go via a spill slot. -- handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts)) - = mapM (makeMove delta vreg src) dsts + = concatMapM (makeMove delta vreg src) dsts -- Handle some cyclic moves. @@ -340,7 +341,7 @@ -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. - return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + return (instrSpill ++ concat remainingFixUps ++ instrLoad) handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" @@ -354,7 +355,7 @@ -> Unique -- ^ unique of the vreg that we're moving. -> Loc -- ^ source location. -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. + -> RegM freeRegs [instr] -- ^ move instruction. makeMove delta vreg src dst = do config <- getConfig @@ -363,7 +364,7 @@ case (src, dst) of (InReg s, InReg d) -> do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) + return $ [mkRegRegMoveInstr platform (RegReal s) (RegReal d)] (InMem s, InReg d) -> do recordSpill (SpillJoinRM vreg) return $ mkLoadInstr config (RegReal d) delta s @@ -377,4 +378,3 @@ panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " we don't handle mem->mem moves.") - diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -46,9 +46,9 @@ getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily getFreeRegs cls (FreeRegs g f) + | RcFloat <- cls = [] -- no float regs on PowerPC, use double | RcDouble <- cls = go f (0x80000000) 63 | RcInteger <- cls = go g (0x80000000) 31 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) where go _ 0 _ = [] go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1) diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -121,7 +121,7 @@ spillR :: Instruction instr - => Reg -> Unique -> RegM freeRegs (instr, Int) + => Reg -> Unique -> RegM freeRegs ([instr], Int) spillR reg temp = mkRegM $ \s -> let (stack1,slot) = getStackSlotFor (ra_stack s) temp @@ -131,7 +131,7 @@ loadR :: Instruction instr - => Reg -> Int -> RegM freeRegs instr + => Reg -> Int -> RegM freeRegs [instr] loadR reg slot = mkRegM $ \s -> RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot) diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -17,7 +17,7 @@ import GHC.Types.Unique.FM import GHC.Utils.Outputable -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons 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 @@ -65,7 +65,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Data.Bag -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict import Data.List (mapAccumL, groupBy, partition) import Data.Maybe @@ -174,7 +174,9 @@ pprInstr platform i = ppr (fmap (pprInstr platform) i) + mkComment = fmap Instr . mkComment + -- | An instruction with liveness information. data LiveInstr instr = LiveInstr (InstrSR instr) (Maybe Liveness) @@ -565,16 +567,20 @@ where (instrs', _) = runState (spillNat [] lis) 0 + -- spillNat :: [instr] -> [LiveInstr instr] -> State Int [instr] + spillNat :: Instruction instr => [instr] -> [LiveInstr instr] -> State Int [instr] spillNat acc [] = return (reverse acc) + -- The SPILL/RELOAD cases do not appear to be exercised by our codegens + -- spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) = do delta <- get - spillNat (mkSpillInstr config reg delta slot : acc) instrs + spillNat (mkSpillInstr config reg delta slot ++ acc) instrs spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) = do delta <- get - spillNat (mkLoadInstr config reg delta slot : acc) instrs + spillNat (mkLoadInstr config reg delta slot ++ acc) instrs spillNat acc (LiveInstr (Instr instr) _ : instrs) | Just i <- takeDeltaInstr instr diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -34,7 +34,9 @@ import qualified GHC.CmmToAsm.X86.RegInfo as X86 import qualified GHC.CmmToAsm.PPC.Regs as PPC import qualified GHC.CmmToAsm.SPARC.Regs as SPARC +import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 + targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int targetVirtualRegSqueeze platform = case platformArch platform of @@ -46,7 +48,7 @@ ArchSPARC64 -> panic "targetVirtualRegSqueeze ArchSPARC64" ArchPPC_64 _ -> PPC.virtualRegSqueeze ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" - ArchAArch64 -> panic "targetVirtualRegSqueeze ArchAArch64" + ArchAArch64 -> AArch64.virtualRegSqueeze ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" @@ -66,7 +68,7 @@ ArchSPARC64 -> panic "targetRealRegSqueeze ArchSPARC64" ArchPPC_64 _ -> PPC.realRegSqueeze ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" - ArchAArch64 -> panic "targetRealRegSqueeze ArchAArch64" + ArchAArch64 -> AArch64.realRegSqueeze ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" @@ -85,7 +87,7 @@ ArchSPARC64 -> panic "targetClassOfRealReg ArchSPARC64" ArchPPC_64 _ -> PPC.classOfRealReg ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" - ArchAArch64 -> panic "targetClassOfRealReg ArchAArch64" + ArchAArch64 -> AArch64.classOfRealReg ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" @@ -104,7 +106,7 @@ ArchSPARC64 -> panic "targetMkVirtualReg ArchSPARC64" ArchPPC_64 _ -> PPC.mkVirtualReg ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" - ArchAArch64 -> panic "targetMkVirtualReg ArchAArch64" + ArchAArch64 -> AArch64.mkVirtualReg ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" @@ -123,7 +125,7 @@ ArchSPARC64 -> panic "targetRegDotColor ArchSPARC64" ArchPPC_64 _ -> PPC.regDotColor ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" - ArchAArch64 -> panic "targetRegDotColor ArchAArch64" + ArchAArch64 -> AArch64.regDotColor ArchAlpha -> panic "targetRegDotColor ArchAlpha" ArchMipseb -> panic "targetRegDotColor ArchMipseb" ArchMipsel -> panic "targetRegDotColor ArchMipsel" diff --git a/compiler/GHC/CmmToAsm/SPARC.hs b/compiler/GHC/CmmToAsm/SPARC.hs --- a/compiler/GHC/CmmToAsm/SPARC.hs +++ b/compiler/GHC/CmmToAsm/SPARC.hs @@ -69,7 +69,6 @@ takeRegRegMoveInstr = SPARC.takeRegRegMoveInstr mkJumpInstr = SPARC.mkJumpInstr pprInstr = SPARC.pprInstr + mkComment = const [] mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" - - diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Instr.hs @@ -362,7 +362,7 @@ -> Reg -- ^ register to spill -> Int -- ^ current stack delta -> Int -- ^ spill slot to use - -> Instr + -> [Instr] mkSpillInstr config reg _ slot = let platform = ncgPlatform config @@ -373,7 +373,7 @@ RcFloat -> FF32 RcDouble -> FF64 - in ST fmt reg (fpRel (negate off_w)) + in [ST fmt reg (fpRel (negate off_w))] -- | Make a spill reload instruction. @@ -382,7 +382,7 @@ -> Reg -- ^ register to load into -> Int -- ^ current stack delta -> Int -- ^ spill slot to use - -> Instr + -> [Instr] mkLoadInstr config reg _ slot = let platform = ncgPlatform config @@ -393,7 +393,7 @@ RcFloat -> FF32 RcDouble -> FF64 - in LD fmt (fpRel (- off_w)) reg + in [LD fmt (fpRel (- off_w)) reg] -------------------------------------------------------------------------------- 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 @@ -62,4 +62,4 @@ mkStackAllocInstr = X86.mkStackAllocInstr mkStackDeallocInstr = X86.mkStackDeallocInstr pprInstr = X86.pprInstr - + mkComment = const [] 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 @@ -672,15 +672,15 @@ -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use - -> Instr + -> [Instr] mkSpillInstr config reg delta slot = let off = spillSlotToOffset platform slot - delta in case targetClassOfReg platform reg of - RcInteger -> MOV (archWordFormat is32Bit) - (OpReg reg) (OpAddr (spRel platform off)) - RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off)) + RcInteger -> [MOV (archWordFormat is32Bit) + (OpReg reg) (OpAddr (spRel platform off))] + RcDouble -> [MOV FF64 (OpReg reg) (OpAddr (spRel platform off))] _ -> panic "X86.mkSpillInstr: no match" where platform = ncgPlatform config is32Bit = target32Bit platform @@ -691,16 +691,16 @@ -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use - -> Instr + -> [Instr] mkLoadInstr config reg delta slot = let off = spillSlotToOffset platform slot - delta in case targetClassOfReg platform reg of - RcInteger -> MOV (archWordFormat is32Bit) - (OpAddr (spRel platform off)) (OpReg reg) - RcDouble -> MOV FF64 (OpAddr (spRel platform off)) (OpReg reg) - _ -> panic "X86.mkLoadInstr" + RcInteger -> ([MOV (archWordFormat is32Bit) + (OpAddr (spRel platform off)) (OpReg reg)]) + RcDouble -> ([MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)]) + _ -> panic "X86.mkLoadInstr" where platform = ncgPlatform config is32Bit = target32Bit platform diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -25,12 +25,14 @@ ) where --- Cmm stuff import GHC.Prelude +import GHC.Platform + +import GHC.CmmToAsm.CPrim + import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Types.ForeignCall import GHC.Cmm hiding (pprBBlock) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Dataflow.Block @@ -39,19 +41,16 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch --- Utils -import GHC.CmmToAsm.CPrim -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform +import GHC.Types.ForeignCall import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique + +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Trace --- The rest import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Control.Monad.ST diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -48,29 +48,29 @@ -> Stream.Stream IO RawCmmGroup a -> IO a llvmCodeGen logger dflags h cmm_stream - = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do + = withTiming logger (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h -- Pass header - showPass logger dflags "LLVM CodeGen" + showPass logger "LLVM CodeGen" -- get llvm version, cache for later use mb_ver <- figureLlvmVersion logger dflags -- warn if unsupported forM_ mb_ver $ \ver -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Using LLVM version:" <+> text (llvmVersionStr ver)) let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $ + when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $ "You are using an unsupported version of LLVM!" $$ - "Currently only" <+> text (llvmVersionStr supportedLlvmVersionMin) <+> - "to" <+> text (llvmVersionStr supportedLlvmVersionMax) <+> "is supported." <+> + "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+> + "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." let isS390X = platformArch (targetPlatform dflags) == ArchS390X let major_ver = head . llvmVersionList $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $ + 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) @@ -78,7 +78,7 @@ -- currently don't use the LLVM version to guide code generation -- so this is okay. let llvm_ver :: LlvmVersion - llvm_ver = fromMaybe supportedLlvmVersionMin mb_ver + llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver -- run code generation a <- runLlvm logger dflags llvm_ver bufh $ diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -15,7 +15,7 @@ LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion, supportedLlvmVersionMin, supportedLlvmVersionMax, + LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionSupported, parseLlvmVersion, llvmVersionStr, llvmVersionList, @@ -263,7 +263,6 @@ -- * Llvm Version -- --- Newtype to avoid using the Eq instance! newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } deriving (Eq, Ord) @@ -281,14 +280,17 @@ where (ver_str, rest) = span isDigit s --- | The LLVM Version that is currently supported. -supportedLlvmVersionMin, supportedLlvmVersionMax :: LlvmVersion -supportedLlvmVersionMin = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) -supportedLlvmVersionMax = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) +-- | The (inclusive) lower bound on the LLVM Version that is currently supported. +supportedLlvmVersionLowerBound :: LlvmVersion +supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) +-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. +supportedLlvmVersionUpperBound :: LlvmVersion +supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) + llvmVersionSupported :: LlvmVersion -> Bool llvmVersionSupported v = - v > supportedLlvmVersionMin && v <= supportedLlvmVersionMax + v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound llvmVersionStr :: LlvmVersion -> String llvmVersionStr = intercalate "." . map show . llvmVersionList @@ -425,9 +427,8 @@ -- | Dumps the document if the corresponding flag has been set by the user dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do - dflags <- getDynFlags logger <- getLogger - liftIO $ dumpIfSet_dyn logger dflags flag hdr fmt doc + liftIO $ putDumpFileMaybe logger flag hdr fmt doc -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM () diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -13,30 +13,25 @@ import GHC.Prelude -import GHC.Driver.Session ( DynFlags, targetPlatform ) -import GHC.Platform ( platformArch, Arch(..) ) -import GHC.Utils.Error ( withTiming ) -import GHC.Utils.Outputable ( text ) -import GHC.Utils.Logger +import GHC.Platform ( Platform, platformArch, Arch(..) ) import GHC.Utils.Exception (try) import qualified Data.ByteString.Char8 as B import System.IO -- | Read in assembly file and process -llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-} - withTiming logger dflags (text "LLVM Mangler") id $ - withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do - go r w - hClose r - hClose w - return () +llvmFixupAsm :: Platform -> FilePath -> FilePath -> IO () +llvmFixupAsm platform f1 f2 = {-# SCC "llvm_mangler" #-} + withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do + go r w + hClose r + hClose w + return () where go :: Handle -> Handle -> IO () go r w = do e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) - let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w + let writeline a = B.hPutStrLn w (rewriteLine platform rewrites a) >> go r w case e_l of Right l -> writeline l Left _ -> return () @@ -45,12 +40,12 @@ rewrites :: [Rewrite] rewrites = [rewriteSymType, rewriteAVX, rewriteCall] -type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString +type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString -- | Rewrite a line of assembly source with the given rewrites, -- taking the first rewrite that applies. -rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString -rewriteLine dflags rewrites l +rewriteLine :: Platform -> [Rewrite] -> B.ByteString -> B.ByteString +rewriteLine platform rewrites l -- We disable .subsections_via_symbols on darwin and ios, as the llvm code -- gen uses prefix data for the info table. This however does not prevent -- llvm from generating .subsections_via_symbols, which in turn with @@ -58,7 +53,7 @@ | isSubsectionsViaSymbols l = (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") | otherwise = - case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of + case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of Nothing -> l Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] where @@ -97,13 +92,13 @@ -- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then -- rewrites the instructions in the mangler. rewriteAVX :: Rewrite -rewriteAVX dflags s +rewriteAVX platform s | not isX86_64 = Nothing | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s | otherwise = Nothing where - isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 + isX86_64 = platformArch platform == ArchX86_64 isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") isVmovap = B.isPrefixOf (B.pack "vmovap") @@ -111,13 +106,13 @@ -- functions on riscv64. The replacement will load the address from the -- GOT, which is resolved to point to the real address of the function. rewriteCall :: Rewrite -rewriteCall dflags l +rewriteCall platform l | not isRISCV64 = Nothing | isCall l = Just $ replaceCall "call" "jalr" "ra" l | isTail l = Just $ replaceCall "tail" "jr" "t1" l | otherwise = Nothing where - isRISCV64 = platformArch (targetPlatform dflags) == ArchRISCV64 + isRISCV64 = platformArch platform == ArchRISCV64 isCall = B.isPrefixOf (B.pack "call\t") isTail = B.isPrefixOf (B.pack "tail\t") diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs deleted file mode 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ /dev/null @@ -1,390 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# OPTIONS_GHC -Wno-orphans #-} - -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt) - -module GHC.Core.Map.Expr ( - -- * Maps over Core expressions - CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - -- * 'TrieMap' class reexports - TrieMap(..), insertTM, deleteTM, - lkDFreeVar, xtDFreeVar, - lkDNamed, xtDNamed, - (>.>), (|>), (|>>), - ) where - -import GHC.Prelude - -import GHC.Data.TrieMap -import GHC.Core.Map.Type -import GHC.Core -import GHC.Core.Type -import GHC.Types.Tickish -import GHC.Types.Var - -import GHC.Utils.Misc -import GHC.Utils.Outputable - -import qualified Data.Map as Map -import GHC.Types.Name.Env -import Control.Monad( (>=>) ) - -{- -This module implements TrieMaps over Core related data structures -like CoreExpr or Type. It is built on the Tries from the TrieMap -module. - -The code is very regular and boilerplate-like, but there is -some neat handling of *binders*. In effect they are deBruijn -numbered on the fly. - - --} - ----------------------- --- Recall that --- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c - --- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not --- known when defining GenMap so we can only specialize them here. - -{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} -{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} -{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} -{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} - - -{- -************************************************************************ -* * - CoreMap -* * -************************************************************************ --} - -{- -Note [Binders] -~~~~~~~~~~~~~~ - * In general we check binders as late as possible because types are - less likely to differ than expression structure. That's why - cm_lam :: CoreMapG (TypeMapG a) - rather than - cm_lam :: TypeMapG (CoreMapG a) - - * We don't need to look at the type of some binders, notably - - the case binder in (Case _ b _ _) - - the binders in an alternative - because they are totally fixed by the context - -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* For a key (Case e b ty (alt:alts)) we don't need to look the return type - 'ty', because every alternative has that type. - -* For a key (Case e b ty []) we MUST look at the return type 'ty', because - otherwise (Case (error () "urk") _ Int []) would compare equal to - (Case (error () "urk") _ Bool []) - which is utterly wrong (#6097) - -We could compare the return type regardless, but the wildly common case -is that it's unnecessary, so we have two fields (cm_case and cm_ecase) -for the two possibilities. Only cm_ecase looks at the type. - -See also Note [Empty case alternatives] in GHC.Core. --} - --- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this --- is the type you want. -newtype CoreMap a = CoreMap (CoreMapG a) - -instance TrieMap CoreMap where - type Key CoreMap = CoreExpr - emptyTM = CoreMap emptyTM - lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m - alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) - foldTM k (CoreMap m) = foldTM k m - mapTM f (CoreMap m) = CoreMap (mapTM f m) - filterTM f (CoreMap m) = CoreMap (filterTM f m) - --- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended --- key makes it suitable for recursive traversal, since it can track binders, --- but it is strictly internal to this module. If you are including a 'CoreMap' --- inside another 'TrieMap', this is the type you want. -type CoreMapG = GenMap CoreMapX - --- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without --- the 'GenMap' optimization. -data CoreMapX a - = CM { cm_var :: VarMap a - , cm_lit :: LiteralMap a - , cm_co :: CoercionMapG a - , cm_type :: TypeMapG a - , cm_cast :: CoreMapG (CoercionMapG a) - , cm_tick :: CoreMapG (TickishMap a) - , cm_app :: CoreMapG (CoreMapG a) - , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] - , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) - , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) - , cm_case :: CoreMapG (ListMap AltMap a) - , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] - } - -instance Eq (DeBruijn CoreExpr) where - D env1 e1 == D env2 e2 = go e1 e2 where - go (Var v1) (Var v2) - = case (lookupCME env1 v1, lookupCME env2 v2) of - (Just b1, Just b2) -> b1 == b2 - (Nothing, Nothing) -> v1 == v2 - _ -> False - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = D env1 t1 == D env2 t2 - go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 - go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 - go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 - -- This seems a bit dodgy, see 'eqTickish' - go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 - - go (Lam b1 e1) (Lam b2 e2) - = D env1 (varType b1) == D env2 (varType b2) - && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) - && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 - - go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) - = go r1 r2 - && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 - - go (Let (Rec ps1) e1) (Let (Rec ps2) e2) - = equalLength ps1 ps2 - && D env1' rs1 == D env2' rs2 - && D env1' e1 == D env2' e2 - where - (bs1,rs1) = unzip ps1 - (bs2,rs2) = unzip ps2 - env1' = extendCMEs env1 bs1 - env2' = extendCMEs env2 bs2 - - go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | null a1 -- See Note [Empty case alternatives] - = null a2 && go e1 e2 && D env1 t1 == D env2 t2 - | otherwise - = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 - - go _ _ = False - -emptyE :: CoreMapX a -emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM - , cm_co = emptyTM, cm_type = emptyTM - , cm_cast = emptyTM, cm_app = emptyTM - , cm_lam = emptyTM, cm_letn = emptyTM - , cm_letr = emptyTM, cm_case = emptyTM - , cm_ecase = emptyTM, cm_tick = emptyTM } - -instance TrieMap CoreMapX where - type Key CoreMapX = DeBruijn CoreExpr - emptyTM = emptyE - lookupTM = lkE - alterTM = xtE - foldTM = fdE - mapTM = mapE - filterTM = ftE - --------------------------- -mapE :: (a->b) -> CoreMapX a -> CoreMapX b -mapE f (CM { cm_var = cvar, cm_lit = clit - , cm_co = cco, cm_type = ctype - , cm_cast = ccast , cm_app = capp - , cm_lam = clam, cm_letn = cletn - , cm_letr = cletr, cm_case = ccase - , cm_ecase = cecase, cm_tick = ctick }) - = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit - , cm_co = mapTM f cco, cm_type = mapTM f ctype - , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp - , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn - , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase - , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } - -ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a -ftE f (CM { cm_var = cvar, cm_lit = clit - , cm_co = cco, cm_type = ctype - , cm_cast = ccast , cm_app = capp - , cm_lam = clam, cm_letn = cletn - , cm_letr = cletr, cm_case = ccase - , cm_ecase = cecase, cm_tick = ctick }) - = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit - , cm_co = filterTM f cco, cm_type = filterTM f ctype - , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp - , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn - , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase - , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick } - --------------------------- -lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a -lookupCoreMap cm e = lookupTM e cm - -extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a -extendCoreMap m e v = alterTM e (\_ -> Just v) m - -foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b -foldCoreMap k z m = foldTM k m z - -emptyCoreMap :: CoreMap a -emptyCoreMap = emptyTM - -instance Outputable a => Outputable (CoreMap a) where - ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) - -------------------------- -fdE :: (a -> b -> b) -> CoreMapX a -> b -> b -fdE k m - = foldTM k (cm_var m) - . foldTM k (cm_lit m) - . foldTM k (cm_co m) - . foldTM k (cm_type m) - . foldTM (foldTM k) (cm_cast m) - . foldTM (foldTM k) (cm_tick m) - . foldTM (foldTM k) (cm_app m) - . foldTM (foldTM k) (cm_lam m) - . foldTM (foldTM (foldTM k)) (cm_letn m) - . foldTM (foldTM (foldTM k)) (cm_letr m) - . foldTM (foldTM k) (cm_case m) - . foldTM (foldTM k) (cm_ecase m) - --- lkE: lookup in trie for expressions -lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a -lkE (D env expr) cm = go expr cm - where - go (Var v) = cm_var >.> lkVar env v - go (Lit l) = cm_lit >.> lookupTM l - go (Type t) = cm_type >.> lkG (D env t) - go (Coercion c) = cm_co >.> lkG (D env c) - go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) - go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish - go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) - go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) - >=> lkBndr env v - go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) - >=> lkG (D (extendCME env b) e) >=> lkBndr env b - go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs - env1 = extendCMEs env bndrs - in cm_letr - >.> lkList (lkG . D env1) rhss - >=> lkG (D env1 e) - >=> lkList (lkBndr env1) bndrs - go (Case e b ty as) -- See Note [Empty case alternatives] - | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) - | otherwise = cm_case >.> lkG (D env e) - >=> lkList (lkA (extendCME env b)) as - -xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a -xtE (D env (Var v)) f m = m { cm_var = cm_var m - |> xtVar env v f } -xtE (D env (Type t)) f m = m { cm_type = cm_type m - |> xtG (D env t) f } -xtE (D env (Coercion c)) f m = m { cm_co = cm_co m - |> xtG (D env c) f } -xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } -xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) - |>> xtG (D env c) f } -xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) - |>> xtTickish t f } -xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) - |>> xtG (D env e1) f } -xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m - |> xtG (D (extendCME env v) e) - |>> xtBndr env v f } -xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m - |> xtG (D (extendCME env b) e) - |>> xtG (D env r) - |>> xtBndr env b f } -xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = - let (bndrs,rhss) = unzip prs - env1 = extendCMEs env bndrs - in cm_letr m - |> xtList (xtG . D env1) rhss - |>> xtG (D env1 e) - |>> xtList (xtBndr env1) - bndrs f } -xtE (D env (Case e b ty as)) f m - | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) - |>> xtG (D env ty) f } - | otherwise = m { cm_case = cm_case m |> xtG (D env e) - |>> let env1 = extendCME env b - in xtList (xtA env1) as f } - --- TODO: this seems a bit dodgy, see 'eqTickish' -type TickishMap a = Map.Map CoreTickish a -lkTickish :: CoreTickish -> TickishMap a -> Maybe a -lkTickish = lookupTM - -xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a -xtTickish = alterTM - ------------------------- -data AltMap a -- A single alternative - = AM { am_deflt :: CoreMapG a - , am_data :: DNameEnv (CoreMapG a) - , am_lit :: LiteralMap (CoreMapG a) } - -instance TrieMap AltMap where - type Key AltMap = CoreAlt - emptyTM = AM { am_deflt = emptyTM - , am_data = emptyDNameEnv - , am_lit = emptyTM } - lookupTM = lkA emptyCME - alterTM = xtA emptyCME - foldTM = fdA - mapTM = mapA - filterTM = ftA - -instance Eq (DeBruijn CoreAlt) where - D env1 a1 == D env2 a2 = go a1 a2 where - go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) - = D env1 rhs1 == D env2 rhs2 - go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) - = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) - = dc1 == dc2 && - D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 - go _ _ = False - -mapA :: (a->b) -> AltMap a -> AltMap b -mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) - = AM { am_deflt = mapTM f adeflt - , am_data = mapTM (mapTM f) adata - , am_lit = mapTM (mapTM f) alit } - -ftA :: (a->Bool) -> AltMap a -> AltMap a -ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) - = AM { am_deflt = filterTM f adeflt - , am_data = mapTM (filterTM f) adata - , am_lit = mapTM (filterTM f) alit } - -lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) -lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) -lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc - >=> lkG (D (extendCMEs env bs) rhs) - -xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a -xtA env (Alt DEFAULT _ rhs) f m = - m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (Alt (LitAlt l) _ rhs) f m = - m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } -xtA env (Alt (DataAlt d) bs rhs) f m = - m { am_data = am_data m |> xtDNamed d - |>> xtG (D (extendCMEs env bs) rhs) f } - -fdA :: (a -> b -> b) -> AltMap a -> b -> b -fdA k m = foldTM k (am_deflt m) - . foldTM (foldTM k) (am_data m) - . foldTM (foldTM k) (am_lit m) diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -13,7 +13,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Driver.Session ( DynFlags ) import GHC.Types.Basic import GHC.Core @@ -434,8 +433,8 @@ -- Main entry point -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram -callArityAnalProgram _dflags binds = binds' +callArityAnalProgram :: CoreProgram -> CoreProgram +callArityAnalProgram binds = binds' where (_, binds') = callArityTopLvl [] emptyVarSet binds diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -11,16 +11,16 @@ import GHC.Prelude import GHC.Driver.Session -import GHC.Types.Demand -import GHC.Types.Cpr -import GHC.Core -import GHC.Core.Seq -import GHC.Utils.Outputable + import GHC.Builtin.Names ( runRWKey ) + import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr + import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Core.Multiplicity @@ -28,18 +28,21 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) -import GHC.Utils.Misc -import GHC.Utils.Panic.Plain -import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Core +import GHC.Core.Seq + import GHC.Data.Graph.UnVar -- for UnVarSet import GHC.Data.Maybe ( isJust ) +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic.Plain +import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) +--import GHC.Utils.Trace + import Control.Monad ( guard ) import Data.List ( mapAccumL ) -import GHC.Driver.Ppr -_ = pprTrace -- Tired of commenting out the import all the time - {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that @@ -108,11 +111,11 @@ -- * Analysing programs -- -cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -cprAnalProgram logger dflags fam_envs binds = do +cprAnalProgram :: Logger -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram logger fam_envs binds = do let env = emptyAnalEnv fam_envs let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds - dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ dumpIdInfoOfProgram (ppr . cprSigInfo) binds_plus_cpr -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_cpr `seq` return binds_plus_cpr 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 @@ -43,7 +43,8 @@ import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set --- import GHC.Driver.Ppr +import GHC.Utils.Trace +_ = pprTrace -- Tired of commenting out the import all the time {- ************************************************************************ @@ -340,11 +341,12 @@ -> Demand -- This one takes a *Demand* -> CoreExpr -- Should obey the let/app invariant -> (PlusDmdArg, CoreExpr) -dmdAnalStar env (n :* cd) e - | WithDmdType dmd_ty e' <- dmdAnal env cd e +dmdAnalStar env (n :* sd) e + -- NB: (:*) expands AbsDmd and BotDmd as needed + -- See Note [Analysing with absent demand] + | WithDmdType dmd_ty e' <- dmdAnal env sd e = assertPpr (not (isUnliftedType (exprType e)) || exprOkForSpeculation e) (ppr e) -- The argument 'e' should satisfy the let/app invariant - -- See Note [Analysing with absent demand] in GHC.Types.Demand (toPlusDmdArg $ multDmdType n dmd_ty, e') -- Main Demand Analsysis machinery @@ -427,7 +429,7 @@ WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! - (_ :* case_bndr_sd) = case_bndr_dmd + (_ :* case_bndr_sd) = case_bndr_dmd -- Compute demand on the scrutinee -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv @@ -548,7 +550,7 @@ , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on scrutinee of a product case] - id_dmds = addCaseBndrDmd case_bndr_sd dmds + id_dmds = addCaseBndrDmd case_bndr_sd dmds -- Do not put a thunk into the Alt !new_ids = setBndrsDemandInfo bndrs id_dmds = WithDmdType alt_ty (Alt con new_ids rhs') @@ -557,7 +559,7 @@ Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we analyse an expression with demand A. The "A" means -"absent", so this expression will never be needed. What should happen? +"absent", so this expression will never be needed. What should happen? There are several wrinkles: * We *do* want to analyse the expression regardless. @@ -566,6 +568,15 @@ But we can post-process the results to ignore all the usage demands coming back. This is done by multDmdType. +* Nevertheless, which sub-demand should we pick for analysis? + Since the demand was absent, any would do. Worker/wrapper will replace + absent bindings with an absent filler anyway, so annotations in the RHS + of an absent binding don't matter much. + Picking 'botSubDmd' would be the most useful, but would also look a bit + misleading in the Core output of DmdAnal, because all nested annotations would + be bottoming. Better pick 'seqSubDmd', so that we annotate many of those + nested bindings with A themselves. + * In a previous incarnation of GHC we needed to be extra careful in the case of an *unlifted type*, because unlifted values are evaluated even if they are not used. Example (see #9254): @@ -1295,16 +1306,9 @@ -- Only called for Ids = assert (isId id) $ -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType final_ty new_id + WithDmdType main_ty new_id where - new_id = setIdDemandInfo id dmd - -- Watch out! See note [Lambda-bound unfoldings] - final_ty = case maybeUnfoldingTemplate (idUnfolding id) of - Nothing -> main_ty - Just unf -> main_ty `plusDmdType` unf_ty - where - (unf_ty, _) = dmdAnalStar env dmd unf - + new_id = setIdDemandInfo id dmd main_ty = addDemand dmd dmd_ty' WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id @@ -1374,16 +1378,6 @@ that the strict variables are being used. In that case, we take all free variables mentioned in the (unsound) strictness signature, conservatively approximate the demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". - - -Note [Lambda-bound unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow a lambda-bound variable to carry an unfolding, a facility that is used -exclusively for join points; see Note [Case binders and join points]. If so, -we must be careful to demand-analyse the RHS of the unfolding! Example - \x. \y{=Just x}. -Then if uses 'y', then transitively it uses 'x', and we must not -forget that fact, otherwise we might make 'x' absent when it isn't. ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -41,7 +41,7 @@ import GHC.Types.Id.Info import GHC.Core import GHC.Core.Utils -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -21,13 +21,10 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session - import GHC.Core import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs -import GHC.Core.Opt.Monad ( CoreM ) import GHC.Core.Type import GHC.Types.Basic ( RecFlag(..), isRec ) @@ -36,8 +33,6 @@ import GHC.Types.Var import GHC.Types.Var.Set -import GHC.Unit.Module.ModGuts - import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -47,11 +42,8 @@ actually float any bindings downwards from the top-level. -} -floatInwards :: ModGuts -> CoreM ModGuts -floatInwards pgm@(ModGuts { mg_binds = binds }) - = do { dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) } +floatInwards :: Platform -> CoreProgram -> CoreProgram +floatInwards platform binds = map (fi_top_bind platform) binds where fi_top_bind platform (NonRec binder rhs) = NonRec binder (fiExpr platform [] (freeVars rhs)) diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -19,7 +19,7 @@ import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session -import GHC.Utils.Logger ( dumpIfSet_dyn, DumpFormat (..), Logger ) +import GHC.Utils.Logger import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish @@ -164,23 +164,22 @@ floatOutwards :: Logger -> FloatOutSwitches - -> DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram -floatOutwards logger float_sws dflags us pgm +floatOutwards logger float_sws us pgm = do { let { annotated_w_levels = setLevels float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; - dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:" + putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:" FormatCore (vcat (map ppr annotated_w_levels)); let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "FloatOut stats:" + putDumpFileMaybe logger Opt_D_dump_simpl_stats "FloatOut stats:" FormatText (hcat [ int tlets, text " Lets floated to top level; ", int ntlets, text " Lets floated elsewhere; from ", diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -11,7 +11,6 @@ import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Platform.Ways ( hasWay, Way(WayProf) ) @@ -47,12 +46,12 @@ import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv -import qualified GHC.Utils.Error as Err import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Trace import GHC.Unit.External import GHC.Unit.Module.Env @@ -61,7 +60,6 @@ import GHC.Runtime.Context -import GHC.Types.SrcLoc import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic @@ -69,7 +67,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish -import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr @@ -100,7 +97,7 @@ builtin_passes ; runCorePasses all_passes guts } - ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats "Grand total simplifier statistics" FormatText (pprSimplCount stats) @@ -465,9 +462,8 @@ do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass = do - dflags <- getDynFlags logger <- getLogger - withTiming logger dflags (ppr pass <+> brackets (ppr mod)) + withTiming logger (ppr pass <+> brackets (ppr mod)) (const ()) $ do guts' <- lintAnnots (ppr pass) (doCorePass pass) guts endPass pass (mg_binds guts') (mg_rules guts') @@ -477,40 +473,48 @@ doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do - logger <- getLogger + logger <- getLogger + dflags <- getDynFlags + us <- getUniqueSupplyM + p_fam_env <- getPackageFamInstEnv + let platform = targetPlatform dflags + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } + let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } + case pass of CoreDoSimplify {} -> {-# SCC "Simplify" #-} simplifyPgm pass guts CoreCSE -> {-# SCC "CommonSubExpr" #-} - doPass cseProgram guts + updateBinds cseProgram CoreLiberateCase -> {-# SCC "LiberateCase" #-} - doPassD liberateCase guts + updateBinds (liberateCase dflags) CoreDoFloatInwards -> {-# SCC "FloatInwards" #-} - floatInwards guts + updateBinds (floatInwards platform) CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards logger f) guts + updateBindsM (liftIO . floatOutwards logger f us) CoreDoStaticArgs -> {-# SCC "StaticArgs" #-} - doPassU doStaticArgs guts + updateBinds (doStaticArgs us) CoreDoCallArity -> {-# SCC "CallArity" #-} - doPassD callArityAnalProgram guts + updateBinds callArityAnalProgram CoreDoExitify -> {-# SCC "Exitify" #-} - doPass exitifyProgram guts + updateBinds exitifyProgram CoreDoDemand -> {-# SCC "DmdAnal" #-} - doPassDFRM (dmdAnal logger) guts + updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts)) CoreDoCpr -> {-# SCC "CprAnal" #-} - doPassDFM (cprAnalProgram logger) guts + updateBindsM (liftIO . cprAnalProgram logger fam_envs) CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds guts + updateBinds (wwTopBinds dflags fam_envs us) CoreDoSpecialising -> {-# SCC "Specialise" #-} specProgram guts @@ -521,7 +525,7 @@ CoreAddCallerCcs -> {-# SCC "AddCallerCcs" #-} addCallerCostCentres guts - CoreDoPrintCore -> observe (printCore logger) guts + CoreDoPrintCore -> liftIO $ printCore logger (mg_binds guts) >> return guts CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts CoreDoNothing -> return guts @@ -543,84 +547,26 @@ ************************************************************************ -} -printCore :: Logger -> DynFlags -> CoreProgram -> IO () -printCore logger dflags binds - = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds) +printCore :: Logger -> CoreProgram -> IO () +printCore logger binds + = Logger.logDumpMsg logger "Print Core" (pprCoreBindings binds) ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheckPass current_phase pat guts = do dflags <- getDynFlags logger <- getLogger - withTiming logger dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) + withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do rb <- getRuleBase vis_orphs <- getVisibleOrphanMods let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn ++ (mg_rules guts) let ropts = initRuleOpts dflags - liftIO $ putLogMsg logger dflags Err.MCDump noSrcSpan - $ withPprStyle defaultDumpStyle + liftIO $ logDumpMsg logger "Rule check" (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) return guts -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDUM do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - us <- getUniqueSupplyM - liftIO $ do_pass dflags us binds - -doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) - -doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) - -doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) - -doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassU do_pass = doPassDU (const do_pass) - -doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs) guts - -doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFRM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts - -doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFU do_pass guts = do - dflags <- getDynFlags - us <- getUniqueSupplyM - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPass (do_pass dflags fam_envs us) guts - --- Most passes return no stats and don't change rules: these combinators --- let us lift them to the full blown ModGuts+CoreM world -doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts -doPassM bind_f guts = do - binds' <- bind_f (mg_binds guts) - return (guts { mg_binds = binds' }) - -doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } - --- Observer passes just peek; don't modify the bindings at all -observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts -observe do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - _ <- liftIO $ do_pass dflags binds - return binds - {- ************************************************************************ * * @@ -635,7 +581,7 @@ -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr hsc_env expr - = withTiming logger dflags (text "Simplify [expr]") (const ()) $ + = withTiming logger (text "Simplify [expr]") (const ()) $ do { eps <- hscEPS hsc_env ; ; let rule_env = mkRuleEnv (eps_rule_base eps) [] fi_env = ( eps_fam_inst_env eps @@ -648,10 +594,10 @@ ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $ simplExprGently simpl_env expr - ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" (pprSimplCount counts) + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Simplifier statistics" FormatText (pprSimplCount counts) - ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression" + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" FormatCore (pprCoreExpr expr') @@ -714,8 +660,9 @@ = do { (termination_msg, it_count, counts_out, guts') <- do_iteration 1 [] binds rules - ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags && - dopt Opt_D_dump_simpl_stats dflags) + ; when (logHasDumpFlag logger Opt_D_verbose_core2core + && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ + logDumpMsg logger "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", @@ -766,7 +713,7 @@ occurAnalysePgm this_mod active_unf active_rule rules binds } ; - Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" + Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings tagged_binds); @@ -814,7 +761,7 @@ let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ; + dump_end_iteration logger print_unqual iteration_no counts1 binds2 rules1 ; lintPassResult hsc_env pass binds2 ; -- Loop @@ -832,19 +779,19 @@ simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" ------------------- -dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int +dump_end_iteration :: Logger -> PrintUnqualified -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration logger dflags print_unqual iteration_no counts binds rules - = dumpPassResult logger dflags print_unqual mb_flag hdr pp_counts binds rules +dump_end_iteration logger print_unqual iteration_no counts binds rules + = dumpPassResult logger print_unqual mb_flag hdr pp_counts binds rules where - mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing + mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing -- Show details if Opt_D_dump_simpl_iterations is on - hdr = text "Simplifier iteration=" <> int iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr + hdr = "Simplifier iteration=" ++ show iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr , pprSimplCount counts - , text "---- End of simplifier counts for" <+> hdr ] + , text "---- End of simplifier counts for" <+> text hdr ] {- ************************************************************************ @@ -1060,7 +1007,7 @@ hasShortableIdInfo id = isEmptyRuleInfo (ruleInfo info) && isDefaultInlinePragma (inlinePragInfo info) - && not (isStableUnfolding (unfoldingInfo info)) + && not (isStableUnfolding (realUnfoldingInfo info)) where info = idInfo id @@ -1081,28 +1028,36 @@ Overwriting, rather than merging, seems to work ok. -We also zap the InlinePragma on the lcl_id. It might originally -have had a NOINLINE, which we have now transferred; and we really -want the lcl_id to inline now that its RHS is trivial! +For the lcl_id we + +* Zap the InlinePragma. It might originally have had a NOINLINE, which + we have now transferred; and we really want the lcl_id to inline now + that its RHS is trivial! + +* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, + replacing lcl_id by gbl_id. That won't happen if lcl_id has its original + great big Stable unfolding -} transferIdInfo :: Id -> Id -> (Id, Id) -- See Note [Transferring IdInfo] transferIdInfo exported_id local_id = ( modifyIdInfo transfer exported_id - , local_id `setInlinePragma` defaultInlinePragma ) + , modifyIdInfo zap_info local_id ) where local_info = idInfo local_id - transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info - `setCprSigInfo` cprSigInfo local_info - `setUnfoldingInfo` unfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info + `setCprSigInfo` cprSigInfo local_info + `setUnfoldingInfo` realUnfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info new_info = setRuleInfoHead (idName exported_id) (ruleInfo local_info) -- Remember to set the function-name field of the -- rules as we transfer them from one function to another + zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma + `setUnfoldingInfo` noUnfolding dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram @@ -1111,7 +1066,7 @@ { dmd_strict_dicts = gopt Opt_DictsStrict dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds - Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $ dumpIdInfoOfProgram (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds 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 @@ -77,8 +77,6 @@ import GHC.Prelude -import GHC.Driver.Ppr - import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Core.Utils ( exprType, exprIsHNF @@ -92,6 +90,10 @@ import GHC.Core.FVs -- all of it import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) +import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType + , mightBeUnliftedType, closeOverKindsDSet ) +import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Core.DataCon ( dataConOrigResTy ) import GHC.Types.Id import GHC.Types.Id.Info @@ -107,23 +109,24 @@ import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) -import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType - , mightBeUnliftedType, closeOverKindsDSet ) -import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Types.Unique.Supply +import GHC.Types.Unique.DFM import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) -import GHC.Core.DataCon ( dataConOrigResTy ) + import GHC.Builtin.Types import GHC.Builtin.Names ( runRWKey ) -import GHC.Types.Unique.Supply + +import GHC.Data.FastString + +import GHC.Utils.FV +import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Data.FastString -import GHC.Types.Unique.DFM -import GHC.Utils.FV +import GHC.Utils.Trace + import Data.Maybe -import GHC.Utils.Monad ( mapAccumLM ) {- ************************************************************************ @@ -666,8 +669,8 @@ || hasFreeJoin env fvs -- If there is a free join, don't float -- See Note [Free join points] || isExprLevPoly expr - -- We can't let-bind levity polymorphic expressions - -- See Note [Levity polymorphism invariants] in GHC.Core + -- We can't let-bind representation-polymorphic expressions + -- See Note [Representation polymorphism invariants] in GHC.Core || notWorthFloating expr abs_vars || not float_me = -- Don't float it out diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -13,22 +13,17 @@ import GHC.Prelude import GHC.Platform + import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config + +import GHC.Core import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) -import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 -import GHC.Types.SourceText -import GHC.Types.Id -import GHC.Types.Id.Make ( seqId ) import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make -import GHC.Types.Id.Info -import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) @@ -37,40 +32,51 @@ , dataConRepArgTys, isUnboxedTupleDataCon , StrictnessMark (..) ) import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) -import GHC.Core -import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) -import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd - , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) -import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType(..) , pushCoTyArg, pushCoValArg - , idArityType, etaExpandAT ) + , etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) +import GHC.Core.Multiplicity + +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd + , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic -import GHC.Utils.Monad ( mapAccumLM, liftIO ) -import GHC.Utils.Logger import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) + +import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey ) + import GHC.Data.Maybe ( orElse ) -import Control.Monad +import GHC.Data.FastString +import GHC.Unit.Module ( moduleName, pprModuleName ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) -import GHC.Data.FastString -import GHC.Unit.Module ( moduleName, pprModuleName ) -import GHC.Core.Multiplicity -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) +import GHC.Utils.Trace +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger +import Control.Monad + {- The guts of the simplifier is in this module, but the driver loop for the simplifier is in GHC.Core.Opt.Pipeline @@ -302,16 +308,15 @@ simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env where - dflags = seDynFlags env logger = seLogger env -- trace_bind emits a trace for each top-level binding, which -- helps to locate the tracing for inlining and rule firing trace_bind what thing_inside - | not (dopt Opt_D_verbose_core2core dflags) + | not (logHasDumpFlag logger Opt_D_verbose_core2core) = thing_inside | otherwise - = putTraceMsg logger dflags ("SimplBind " ++ what) + = logTraceMsg logger ("SimplBind " ++ what) (ppr old_bndr) thing_inside -------------------------- @@ -361,8 +366,8 @@ -- ANF-ise a constructor or PAP rhs -- We get at most one float per argument here - ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-} - prepareBinding env top_lvl bndr bndr1 body1 + ; (let_floats, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl bndr1 body1 ; let body_floats2 = body_floats1 `addLetFloats` let_floats ; (rhs_floats, rhs') @@ -387,7 +392,7 @@ ; return (floats, rhs') } ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - top_lvl Nothing bndr bndr2 rhs' + top_lvl Nothing bndr bndr1 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } -------------------------- @@ -427,10 +432,10 @@ ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs } -- NotTopLevel: simplNonRecX is only used for NotTopLevel things -- - -- isStrictId: use bndr' because in a levity-polymorphic setting - -- the InId bndr might have a levity-polymorphic type, which - -- which isStrictId doesn't expect - -- c.f. Note [Dark corner with levity polymorphism] + -- isStrictId: use bndr' because in a representation-polymorphic + -- setting, the InId bndr might have a representation-polymorphic + -- type, which isStrictId doesn't expect + -- c.f. Note [Dark corner with representation polymorphism] -------------------------- completeNonRecX :: TopLevelFlag -> SimplEnv @@ -444,8 +449,7 @@ completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $ - do { (prepd_floats, new_bndr, new_rhs) - <- prepareBinding env top_lvl old_bndr new_bndr new_rhs + do { (prepd_floats, new_rhs) <- prepareBinding env top_lvl new_bndr new_rhs ; let floats = emptyFloats env `addLetFloats` prepd_floats ; (rhs_floats, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs @@ -463,23 +467,25 @@ {- ********************************************************************* * * - prepareBinding, prepareRhs, makeTrivial + Cast worker/wrapper * * ************************************************************************ -Note [Cast worker/wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~ When we have a binding x = e |> co we want to do something very similar to worker/wrapper: $wx = e x = $wx |> co -So now x can be inlined freely. There's a chance that e will be a -constructor application or function, or something like that, so moving -the coercion to the usage site may well cancel the coercions and lead -to further optimisation. Example: +We call this making a cast worker/wrapper in tryCastWorkerWrapper. +The main motivaiton is that x can be inlined freely. There's a chance +that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel +the coercions and lead to further optimisation. Example: + data family T a :: * data instance T Int = T Int @@ -491,39 +497,74 @@ go n = case t of { T m -> go (n-m) } -- This case should optimise -We call this making a cast worker/wrapper, and it's done by prepareBinding. +A second reason for doing cast worker/wrapper is that the worker/wrapper +pass after strictness analysis can't deal with RHSs like + f = (\ a b c. blah) |> co +Instead, it relies on cast worker/wrapper to get rid of the cast, +leaving a simpler job for demand-analysis worker/wrapper. See #19874. -We need to be careful with inline/noinline pragmas: - rec { {-# NOINLINE f #-} - f = (...g...) |> co - ; g = ...f... } -This is legitimate -- it tells GHC to use f as the loop breaker -rather than g. Now we do the cast thing, to get something like - rec { $wf = ...g... - ; f = $wf |> co - ; g = ...f... } -Where should the NOINLINE pragma go? If we leave it on f we'll get - rec { $wf = ...g... - ; {-# NOINLINE f #-} - f = $wf |> co - ; g = ...f... } -and that is bad: the whole point is that we want to inline that -cast! We want to transfer the pagma to $wf: - rec { {-# NOINLINE $wf #-} - $wf = ...g... - ; f = $wf |> co - ; g = ...f... } -It's exactly like worker/wrapper for strictness analysis: +Wrinkles + +1. We must /not/ do cast w/w on + f = g |> co + otherwise it'll just keep repeating forever! You might think this + is avoided because the call to tryCastWorkerWrapper is guarded by + preInlineUnconditinally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnonditionally. + +2. We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } + This is legitimate -- it tells GHC to use f as the loop breaker + rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } + and that is bad: the whole point is that we want to inline that + cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +3. We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding = -} + f = (\xy. ) |> co + Then we want to w/w to + {- $wf: Stable unfolding = |> sym co -} + $wf = \xy. + f = $wf |> co + Notice that the stable unfolding moves to the worker! Now demand analysis + will work fine on $wf, whereas it has trouble with the original f. + c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. + This point also applies to strong loopbreakers with INLINE pragmas, see + wrinkle (4). + +4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence + hasInlineUnfolding in tryCastWorkerWrapper, which responds False to + loop-breakers) because they'll definitely be inlined anyway, cast and + all. And if we do cast w/w for an INLINE function with arity zero, we get + something really silly: we inline that "worker" right back into the wrapper! + Worse than a no-op, because we have then lost the stable unfolding. + +All these wrinkles are exactly like worker/wrapper for strictness analysis: f is the wrapper and must inline like crazy $wf is the worker and must carry f's original pragma -See Note [Worker/wrapper for NOINLINE functions] in -GHC.Core.Opt.WorkWrap. +See Note [Worker/wrapper for INLINABLE functions] +and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. -See #17673, #18093, #18078. +See #17673, #18093, #18078, #19890. Note [Preserve strictness in cast w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Cast worker/wrappers] transformation, keep the strictness info. +In the Note [Cast worker/wrapper] transformation, keep the strictness info. Eg f = e `cast` co -- f has strictness SSL When we transform to @@ -553,41 +594,78 @@ this Note makes much sense any more. -} -prepareBinding :: SimplEnv -> TopLevelFlag - -> InId -> OutId -> OutExpr - -> SimplM (LetFloats, OutId, OutExpr) +tryCastWorkerWrapper :: SimplEnv -> TopLevelFlag + -> InId -> OccInfo + -> OutId -> OutExpr + -> SimplM (SimplFloats, SimplEnv) +-- See Note [Cast worker/wrapper] +tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co) + | not (isJoinId bndr) -- Not for join points + , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform + -- a DFunUnfolding in mk_worker_unfolding + , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 + , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 + , not (isUnliftedType rhs_ty) -- Not if rhs has an unlifted type; + -- see Note [Cast w/w: unlifted] + = do { (rhs_floats, work_rhs) <- prepareRhs mode top_lvl occ_fs rhs + ; uniq <- getUniqueM + ; let work_name = mkSystemVarName uniq occ_fs + work_id = mkLocalIdWithInfo work_name Many rhs_ty worker_info -prepareBinding env top_lvl old_bndr bndr rhs - | Cast rhs1 co <- rhs - -- Try for cast worker/wrapper - -- See Note [Cast worker/wrappers] - , not (isStableUnfolding (realIdUnfolding old_bndr)) - -- Don't make a cast w/w if the thing is going to be inlined anyway - , not (exprIsTrivial rhs1) - -- Nor if the RHS is trivial; then again it'll be inlined - , let ty1 = coercionLKind co - , not (isUnliftedType ty1) - -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted] - = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl - (getOccFS bndr) worker_info rhs1 ty1 - ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) - ; return (floats, bndr', Cast (Var new_id) co) } + ; work_unf <- mk_worker_unfolding work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf + floats = emptyFloats env + `addLetFloats` rhs_floats + `addLetFloats` unitLetFloat (NonRec work_id_w_unf work_rhs) - | otherwise - = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs - ; return (floats, bndr, rhs') } - where - info = idInfo bndr - worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info - `setCprSigInfo` cprSigInfo info - `setDemandInfo` demandInfo info - `setInlinePragInfo` inlinePragInfo info - `setArityInfo` arityInfo info - -- We do /not/ want to transfer OccInfo, Rules, Unfolding - -- Note [Preserve strictness in cast w/w] + triv_rhs = Cast (Var work_id_w_unf) co + ; if postInlineUnconditionally env top_lvl bndr occ_info triv_rhs + -- Almost always True, because the RHS is trivial + -- In that case we want to eliminate the binding fast + -- We conservatively use postInlineUnconditionally so that we + -- check all the right things + then do { tick (PostInlineUnconditionally bndr) + ; return ( floats + , extendIdSubst (setInScopeFromF env floats) old_bndr $ + DoneEx triv_rhs Nothing ) } + + else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + `setIdUnfolding` wrap_unf + floats' = floats `extendFloats` NonRec bndr' triv_rhs + ; return ( floats', setInScopeFromF env floats' ) } } + where + mode = getMode env + occ_fs = getOccFS bndr + rhs_ty = coercionLKind co + info = idInfo bndr + + worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` arityInfo info + -- We do /not/ want to transfer OccInfo, Rules + -- Note [Preserve strictness in cast w/w] + -- and Wrinkle 2 of Note [Cast worker/wrapper] + + ----------- Worker unfolding ----------- + -- Stable case: if there is a stable unfolding we have to compose with (Sym co); + -- the next round of simplification will do the job + -- Non-stable case: use work_rhs + -- Wrinkle 3 of Note [Cast worker/wrapper] + mk_worker_unfolding work_id work_rhs + = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) + _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs + +tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings + = return (mkFloatBind env (NonRec bndr rhs)) + mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma --- See Note [Cast wrappers] +-- See Note [Cast worker/wrapper] mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline] @@ -601,6 +679,19 @@ wrap_act | isNeverActive act = activateDuringFinal | otherwise = act + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +********************************************************************* -} + +prepareBinding :: SimplEnv -> TopLevelFlag + -> OutId -> OutExpr + -> SimplM (LetFloats, OutExpr) +prepareBinding env top_lvl bndr rhs + = prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs + {- Note [prepareRhs] ~~~~~~~~~~~~~~~~~~~~ prepareRhs takes a putative RHS, checks whether it's a PAP or @@ -806,33 +897,34 @@ | otherwise = assert (isId new_bndr) $ do { let old_info = idInfo old_bndr - old_unf = unfoldingInfo old_info + old_unf = realUnfoldingInfo old_info occ_info = occInfo old_info + mode = getMode env -- Do eta-expansion on the RHS of the binding -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils - ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs + ; (new_arity, eta_rhs) <- tryEtaExpandRhs mode new_bndr new_rhs -- Simplify the unfolding ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr - final_rhs (idType new_bndr) new_arity old_unf + eta_rhs (idType new_bndr) new_arity old_unf - ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding + ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding -- See Note [In-scope set as a substitution] - ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs + ; if postInlineUnconditionally env top_lvl new_bndr_w_info occ_info eta_rhs then -- Inline and discard the binding do { tick (PostInlineUnconditionally old_bndr) ; return ( emptyFloats env , extendIdSubst env old_bndr $ - DoneEx final_rhs (isJoinId_maybe new_bndr)) } + DoneEx eta_rhs (isJoinId_maybe new_bndr)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding - else -- Keep the binding + else -- Keep the binding; do cast worker/wrapper -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ - return (mkFloatBind env (NonRec final_bndr final_rhs)) } + tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs } addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId addLetBndrInfo new_bndr new_arity_type new_unf @@ -1486,7 +1578,7 @@ levity_ok MRefl = True levity_ok (MCo co) = not $ isTypeLevPoly $ coercionRKind co -- Without this check, we get a lev-poly arg - -- See Note [Levity polymorphism invariants] in GHC.Core + -- See Note [Representation polymorphism invariants] in GHC.Core -- test: typecheck/should_run/EtaExpandLevPoly simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr @@ -1521,17 +1613,13 @@ | isSimplified dup -- Don't re-simplify if we've simplified it once -- See Note [Avoiding exponential behaviour] = do { tick (BetaReduction bndr) - ; (floats1, env') <- simplNonRecX env zapped_bndr arg + ; (floats1, env') <- simplNonRecX env bndr arg ; (floats2, expr') <- simplLam env' bndrs body cont ; return (floats1 `addFloats` floats2, expr') } | otherwise = do { tick (BetaReduction bndr) - ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont } - where - zapped_bndr -- See Note [Zap unfolding when beta-reducing] - | isId bndr = zapStableUnfolding bndr - | otherwise = bndr + ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } -- Discard a non-counting tick on a lambda. This may change the -- cost attribution slightly (moving the allocation of the @@ -1550,26 +1638,11 @@ ------------- simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda binders. These sometimes have unfoldings added by --- the worker/wrapper pass that must be preserved, because they can't --- be reconstructed from context. For example: --- f x = case x of StrictPair a b -> fw a b x --- fw a{=OtherCon[]} b{=OtherCon[]} x{=(StrictPair a b)} = ... --- The "{=(StrictPair a b)}" is an unfolding we can't reconstruct otherwise. --- Since simplBinder already retains OtherCon bindings we only have to special --- case core unfoldings like the one for `x`. -simplLamBndr env bndr - | isId bndr && hasCoreUnfolding old_unf -- Special case - = do { (env1, bndr1) <- simplBinder env bndr - ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr - (idType bndr1) (idArityType bndr1) old_unf - ; let bndr2 = bndr1 `setIdUnfolding` unf' - ; return (modifyInScope env1 bndr2, bndr2) } - - | otherwise - = simplBinder env bndr -- Normal case - where - old_unf = idUnfolding bndr +-- Historically this had a special case for when a lambda-binder +-- could have a stable unfolding; +-- see Historical Note [Case binders and join points] +-- But now it is much simpler! +simplLamBndr env bndr = simplBinder env bndr simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs @@ -1614,7 +1687,7 @@ = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Deal with strict bindings - -- See Note [Dark corner with levity polymorphism] + -- See Note [Dark corner with representation polymorphism] ; if isStrictId bndr1 && sm_case_case (getMode env) then simplExprF (rhs_se `setInScopeFromE` env) rhs (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body @@ -1646,17 +1719,17 @@ ; (floats2, expr') <- simplExprF env2 body cont ; return (floats1 `addFloats` floats2, expr') } -{- Note [Dark corner with levity polymorphism] +{- Note [Dark corner with representation polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In `simplNonRecE`, the call to `isStrictId` will fail if the binder -has a levity-polymorphic type, of kind (TYPE r). So we are careful to +has a representation-polymorphic type, of kind (TYPE r). So we are careful to call `isStrictId` on the OutId, not the InId, in case we have - ((\(r::RuntimeRep) \(x::Type r). blah) Lifted arg) -That will lead to `simplNonRecE env (x::Type r) arg`, and we can't tell + ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) +That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell if x is lifted or unlifted from that. We only get such redexes from the compulsory inlining of a wired-in, -levity-polymorphic function like `rightSection` (see +representation-polymorphic function like `rightSection` (see GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined such compulsory inlinings already, but belt and braces does no harm. @@ -1694,19 +1767,6 @@ (see Note [Trying rewrite rules]) -Note [Zap unfolding when beta-reducing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Lambda-bound variables can have stable unfoldings, such as - $j = \x. \b{Unf=Just x}. e -See Note [Case binders and join points] below; the unfolding for lets -us optimise e better. However when we beta-reduce it we want to -revert to using the actual value, otherwise we can end up in the -stupid situation of - let x = blah in - let b{Unf=Just x} = y - in ...b... -Here it'd be far better to drop the unfolding and use the actual RHS. - ************************************************************************ * * Join points @@ -1948,7 +2008,7 @@ completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) completeCall env var cont - | Just expr <- callSiteInline logger dflags case_depth var active_unf + | Just expr <- callSiteInline logger uf_opts case_depth var active_unf lone_variable arg_infos interesting_cont -- Inline the variable's RHS = do { checkedTick (UnfoldingDone var) @@ -1965,7 +2025,7 @@ ; rebuildCall env info cont } where - dflags = seDynFlags env + uf_opts = seUnfoldingOpts env case_depth = seCaseDepth env logger = seLogger env (lone_variable, arg_infos, call_cont) = contArgs cont @@ -1974,14 +2034,13 @@ active_unf = activeUnfolding (getMode env) var log_inlining doc - = liftIO $ putDumpMsg logger dflags - (mkDumpStyle alwaysQualify) + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) Opt_D_dump_inlinings "" FormatText doc dump_inline unfolding cont - | not (dopt Opt_D_dump_inlinings dflags) = return () - | not (dopt Opt_D_verbose_core2core dflags) + | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () + | not (logHasDumpFlag logger Opt_D_verbose_core2core) = when (isExternalName (idName var)) $ log_inlining $ sep [text "Inlining done:", nest 4 (ppr var)] @@ -2248,8 +2307,8 @@ (ruleModule rule)) dump rule rule_rhs - | dopt Opt_D_dump_rule_rewrites dflags - = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat [ text "Rule:" <+> ftext (ruleName rule) , text "Module:" <+> printRuleModule rule , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) @@ -2257,8 +2316,8 @@ (sep $ map ppr $ drop (ruleArity rule) args) , text "Cont: " <+> ppr call_cont ] - | dopt Opt_D_dump_rule_firings dflags - = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + | logHasDumpFlag logger Opt_D_dump_rule_firings + = log_rule Opt_D_dump_rule_firings "Rule fired:" $ ftext (ruleName rule) <+> printRuleModule rule @@ -2266,22 +2325,20 @@ = return () nodump - | dopt Opt_D_dump_rule_rewrites dflags + | logHasDumpFlag logger Opt_D_dump_rule_rewrites = liftIO $ - touchDumpFile logger dflags Opt_D_dump_rule_rewrites + touchDumpFile logger Opt_D_dump_rule_rewrites - | dopt Opt_D_dump_rule_firings dflags + | logHasDumpFlag logger Opt_D_dump_rule_firings = liftIO $ - touchDumpFile logger dflags Opt_D_dump_rule_firings + touchDumpFile logger Opt_D_dump_rule_firings | otherwise = return () - log_rule dflags flag hdr details - = liftIO $ do - let sty = mkDumpStyle alwaysQualify - putDumpMsg logger dflags sty flag "" FormatText $ - sep [text hdr, nest 4 details] + log_rule flag hdr details + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText + $ sep [text hdr, nest 4 details] trySeqRules :: SimplEnv -> OutExpr -> InExpr -- Scrutinee and RHS @@ -2510,13 +2567,6 @@ we won't build a thunk because the let is strict. See also Note [Case-to-let for strictly-used binders] - NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make. - We want to turn - case (absentError "foo") of r -> ...MkT r... - into - let r = absentError "foo" in ...MkT r... - - Note [Case-to-let for strictly-used binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have this: @@ -3118,11 +3168,11 @@ informative unfolding. Why? Because suppose a later, less clever, pass simply replaces all occurrences of the case binder with the binder itself; then Lint may complain about the let/app invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... + case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... ; K -> blah } The let/app invariant requires that y is evaluated in the call to -reallyUnsafePtrEq#, which it is. But we still want that to be true if we +reallyUnsafePtrEquality#, which it is. But we still want that to be true if we propagate binders to occurrences. This showed up in #13027. @@ -3519,27 +3569,11 @@ = return (jfloats, Alt con bndrs' rhs') | otherwise - = do { simpl_opts <- initSimpleOpts <$> getDynFlags - ; let rhs_ty' = exprType rhs' - scrut_ty = idType case_bndr - case_bndr_w_unf - = case con of - DEFAULT -> case_bndr - DataAlt dc -> setIdUnfolding case_bndr unf - where - -- See Note [Case binders and join points] - unf = mkInlineUnfolding simpl_opts rhs - rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - - LitAlt {} -> warnPprTrace True - (text "mkDupableAlt" <+> ppr case_bndr <+> ppr con) - case_bndr - -- The case binder is alive but trivial, so why has - -- it not been substituted away? + = do { let rhs_ty' = exprType rhs' final_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs' - | otherwise = bndrs' ++ [case_bndr_w_unf] + | otherwise = bndrs' ++ [case_bndr] abstract_over bndr | isTyVar bndr = True -- Abstract over all type variables just in case @@ -3598,8 +3632,12 @@ See #4957 a fuller example. -Note [Case binders and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Historical Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this entire Note is now irrelevant. In Jun 21 we stopped +adding unfoldings to lambda binders (#17530). It was always a +hack and bit us in multiple small and not-so-small ways + Consider this case (case .. ) of c { I# c# -> ....c.... diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -169,9 +169,8 @@ traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc - = do dflags <- getDynFlags - logger <- getLogger - liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace" + = do logger <- getLogger + liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace" FormatText (hang (text herald) 2 doc) {-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -39,11 +39,12 @@ import GHC.Prelude -import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) import GHC.Driver.Session -import GHC.Driver.Ppr + import GHC.Core +import GHC.Types.Literal ( isLitRubbish ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) @@ -52,28 +53,31 @@ import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding( substTy ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Core.Multiplicity +import GHC.Core.Opt.ConstantFold + import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Tickish -import GHC.Types.Var import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic -import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Type hiding( substTy ) -import GHC.Core.Coercion hiding( substCo ) -import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) -import GHC.Core.Multiplicity -import GHC.Utils.Misc + import GHC.Data.OrdList ( isNilOL ) +import GHC.Data.FastString ( fsLit ) + +import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Core.Opt.ConstantFold -import GHC.Data.FastString ( fsLit ) +import GHC.Utils.Trace import Control.Monad ( when ) import Data.List ( sortBy ) @@ -425,7 +429,8 @@ contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k -contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k +-- This one doesn't look right. A value application is not trivial +-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k contIsTrivial (CastIt _ k) = contIsTrivial k contIsTrivial _ = False @@ -586,8 +591,8 @@ Just False -> strictifyDmd dmd _ -> dmd = dmd' : add_type_strictness fun_ty' rest_dmds - -- If the type is levity-polymorphic, we can't know whether it's - -- strict. isLiftedType_maybe will return Just False only when + -- If the type is representation-polymorphic, we can't know whether + -- it's strict. isLiftedType_maybe will return Just False only when -- we're sure the type is unlifted. | otherwise @@ -815,7 +820,9 @@ DoneEx e _ -> go (zapSubstEnv env) n e ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e - go _ _ (Lit {}) = ValueArg + go _ _ (Lit l) + | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 + | otherwise = ValueArg go _ _ (Type _) = TrivArg go _ _ (Coercion _) = TrivArg go env n (App fn (Type _)) = go env n fn @@ -1922,6 +1929,14 @@ otherwise we get t = /\ (f:k->*) (a:k). AccFailure @ (f a) which is obviously bogus. + + * We get the variables to abstract over by filtering down the + the main_tvs for the original function, picking only ones + mentioned in the abstracted body. This means: + - they are automatically in dependency order, because main_tvs is + - there is no issue about non-determinism + - we don't gratuitiously change order, which may help (in a tiny + way) with CSE and/or the compiler-debugging experience -} abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats @@ -1933,7 +1948,6 @@ ; return (float_binds, GHC.Core.Subst.substExpr subst body) } where is_top_lvl = isTopLevel top_lvl - main_tv_set = mkVarSet main_tvs body_floats = letFloatBinds (sfLetFloats floats) empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) @@ -1947,10 +1961,9 @@ rhs' = GHC.Core.Subst.substExpr subst rhs -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = scopedSort $ - filter (`elemVarSet` main_tv_set) $ - closeOverKindsList $ - exprSomeFreeVarsList isTyVar rhs' + tvs_here = filter (`elemVarSet` free_tvs) main_tvs + free_tvs = closeOverKinds $ + exprSomeFreeVars isTyVar rhs' abstract subst (Rec prs) = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids 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 @@ -21,14 +21,15 @@ import GHC.Prelude +import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) + , gopt, hasPprDebug ) + import GHC.Core import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold import GHC.Core.FVs ( exprsFreeVarsList ) import GHC.Core.Opt.Monad -import GHC.Types.Literal ( litIsLifted ) -import GHC.Unit.Module.ModGuts import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs ) import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) @@ -36,35 +37,42 @@ import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity -import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr ) import GHC.Core.Make ( mkImpossibleExpr ) + +import GHC.Unit.Module +import GHC.Unit.Module.ModGuts + +import GHC.Types.Literal ( litIsLifted ) +import GHC.Types.Id import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Basic -import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) - , gopt, hasPprDebug ) -import GHC.Driver.Ppr -import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Serialized ( deserializeWithData ) -import GHC.Utils.Misc -import GHC.Data.Pair import GHC.Types.Unique.Supply +import GHC.Types.Unique.FM + +import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) +import GHC.Data.Pair +import GHC.Data.FastString + +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) -import GHC.Data.FastString -import GHC.Types.Unique.FM import GHC.Utils.Monad -import Control.Monad ( zipWithM ) -import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) +import GHC.Utils.Trace + import GHC.Builtin.Names ( specTyConKey ) -import GHC.Unit.Module + import GHC.Exts( SpecConstrAnnotation(..) ) +import GHC.Serialized ( deserializeWithData ) + +import Control.Monad ( zipWithM ) +import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) import Data.Ord( comparing ) {- 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 @@ -15,6 +15,7 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config +import GHC.Driver.Config.Diagnostic import GHC.Driver.Env import GHC.Tc.Utils.TcType hiding( substTy ) @@ -27,6 +28,7 @@ import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core +import GHC.Core.Make ( mkLitRubbish ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe @@ -41,16 +43,15 @@ import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) import GHC.Data.Bag import GHC.Data.FastString +import GHC.Data.List.SetOps import GHC.Types.Basic import GHC.Types.Unique.Supply import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Tickish -import GHC.Types.RepType ( typeMonoPrimRep_maybe ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var ( isLocalVar ) -import GHC.Types.Literal ( mkLitRubbish ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id @@ -61,6 +62,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Trace import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts @@ -815,8 +817,9 @@ | otherwise = return () where allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers + diag_opts = initDiagOpts dflags doWarn reason = - msg (mkMCDiagnostic dflags reason) + msg (mkMCDiagnostic diag_opts reason) (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) @@ -1761,7 +1764,7 @@ unfolding of the specialised function: this is the last field in specHeader's big result tuple. - The right thing to do is to produce a RubbishLit; it should rapidly + The right thing to do is to produce a LitRubbish; it should rapidly disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. Note [Zap occ info in rule binders] @@ -2346,8 +2349,8 @@ -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let (mb_spec_bndr, spec_arg) | isDeadBinder bndr - , Just reps <- typeMonoPrimRep_maybe bndr_ty - = (Nothing, mkTyApps (Lit (mkLitRubbish reps)) [bndr_ty]) + , Just lit_expr <- mkLitRubbish bndr_ty + = (Nothing, lit_expr) | otherwise = (Just bndr', varToCoreExpr bndr') diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -9,32 +9,34 @@ import GHC.Prelude +import GHC.Driver.Session + import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) -import GHC.Core.FVs ( exprFreeVars ) +import GHC.Core.Type +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Core.FamInstEnv +import GHC.Core.SimpleOpt( SimpleOpts(..) ) + import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Core.Type import GHC.Types.Unique.Supply import GHC.Types.Basic -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.SourceText -import GHC.Core.Opt.WorkWrap.Utils +import GHC.Types.Unique + import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.Unique import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Core.FamInstEnv import GHC.Utils.Monad +import GHC.Utils.Trace {- We take Core bindings whose binders have: @@ -68,8 +70,10 @@ wwTopBinds dflags fam_envs us top_binds = initUs_ us $ do - top_binds' <- mapM (wwBind dflags fam_envs) top_binds + top_binds' <- mapM (wwBind ww_opts) top_binds return (concat top_binds') + where + ww_opts = initWwOpts dflags fam_envs {- ************************************************************************ @@ -82,25 +86,24 @@ turn. Non-recursive case first, then recursive... -} -wwBind :: DynFlags - -> FamInstEnvs +wwBind :: WwOpts -> CoreBind -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; -- the caller will convert to Expr/Binding, -- as appropriate. -wwBind dflags fam_envs (NonRec binder rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs +wwBind ww_opts (NonRec binder rhs) = do + new_rhs <- wwExpr ww_opts rhs + new_pairs <- tryWW ww_opts NonRecursive binder new_rhs return [NonRec b e | (b,e) <- new_pairs] -- Generated bindings must be non-recursive -- because the original binding was. -wwBind dflags fam_envs (Rec pairs) +wwBind ww_opts (Rec pairs) = return . Rec <$> concatMapM do_one pairs where - do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs - tryWW dflags fam_envs Recursive binder new_rhs + do_one (binder, rhs) = do new_rhs <- wwExpr ww_opts rhs + tryWW ww_opts Recursive binder new_rhs {- @wwExpr@ basically just walks the tree, looking for appropriate @@ -109,41 +112,41 @@ @wwExpr@ is a version that just returns the ``Plain'' Tree. -} -wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr +wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr -wwExpr _ _ e@(Type {}) = return e -wwExpr _ _ e@(Coercion {}) = return e -wwExpr _ _ e@(Lit {}) = return e -wwExpr _ _ e@(Var {}) = return e +wwExpr _ e@(Type {}) = return e +wwExpr _ e@(Coercion {}) = return e +wwExpr _ e@(Lit {}) = return e +wwExpr _ e@(Var {}) = return e -wwExpr dflags fam_envs (Lam binder expr) - = Lam new_binder <$> wwExpr dflags fam_envs expr +wwExpr ww_opts (Lam binder expr) + = Lam new_binder <$> wwExpr ww_opts expr where new_binder | isId binder = zapIdUsedOnceInfo binder | otherwise = binder -- See Note [Zapping Used Once info in WorkWrap] -wwExpr dflags fam_envs (App f a) - = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a +wwExpr ww_opts (App f a) + = App <$> wwExpr ww_opts f <*> wwExpr ww_opts a -wwExpr dflags fam_envs (Tick note expr) - = Tick note <$> wwExpr dflags fam_envs expr +wwExpr ww_opts (Tick note expr) + = Tick note <$> wwExpr ww_opts expr -wwExpr dflags fam_envs (Cast expr co) = do - new_expr <- wwExpr dflags fam_envs expr +wwExpr ww_opts (Cast expr co) = do + new_expr <- wwExpr ww_opts expr return (Cast new_expr co) -wwExpr dflags fam_envs (Let bind expr) - = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr +wwExpr ww_opts (Let bind expr) + = mkLets <$> wwBind ww_opts bind <*> wwExpr ww_opts expr -wwExpr dflags fam_envs (Case expr binder ty alts) = do - new_expr <- wwExpr dflags fam_envs expr +wwExpr ww_opts (Case expr binder ty alts) = do + new_expr <- wwExpr ww_opts expr new_alts <- mapM ww_alt alts let new_binder = zapIdUsedOnceInfo binder -- See Note [Zapping Used Once info in WorkWrap] return (Case new_expr new_binder ty new_alts) where ww_alt (Alt con binders rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs + new_rhs <- wwExpr ww_opts rhs let new_binders = [ if isId b then zapIdUsedOnceInfo b else b | b <- binders ] -- See Note [Zapping Used Once info in WorkWrap] @@ -206,7 +209,7 @@ fw d x y' = let y = I# y' in ...f... How do we "transfer the unfolding"? Easy: by using the old one, wrapped -in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. +in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. Note [No worker/wrapper for record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -224,6 +227,8 @@ in advance...the logic in mkWwBodies is complex. So I've left the super-simple test, with this Note to explain. +NB: record selectors are ordinary functions, inlined iff GHC wants to, +so won't be caught by the preceding isInlineUnfolding test in tryWW. Note [Worker/wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -461,7 +466,7 @@ exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f; it's syntactically illegal. - - Otherwise inline wrapper in phase 2. That allows the + - Otherwise inline wrapper in phase Final. That allows the 'gentle' simplification pass to apply specialisation rules Note [Wrapper NoUserInlinePrag] @@ -477,10 +482,20 @@ everything we needs is expressed by (a) the stable unfolding and (b) the inl_act activation.) +Note [Drop absent bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19824): + let t = ...big... + in ...(f t x)... + +were `f` ignores its first argument. With luck f's wrapper will inline +thereby dropping `t`, but maybe not: the arguments to f all look boring. + +So we pre-empt the problem by replacing t's RHS with an absent filler. +Simple and effective. -} -tryWW :: DynFlags - -> FamInstEnvs +tryWW :: WwOpts -> RecFlag -> Id -- The fn binder -> CoreExpr -- The bound rhs; its innards @@ -490,46 +505,45 @@ -- the orig "wrapper" lives on); -- if two, then a worker and a -- wrapper. -tryWW dflags fam_envs is_rec fn_id rhs +tryWW ww_opts is_rec fn_id rhs + -- Do this even if there is a NOINLINE pragma -- See Note [Worker/wrapper for NOINLINE functions] - | Just stable_unf <- certainlyWillInline uf_opts fn_info - = return [ (new_fn_id `setIdUnfolding` stable_unf, rhs) ] - -- See Note [Don't w/w INLINE things] - -- See Note [Don't w/w inline small non-loop-breaker things] + -- See Note [Drop absent bindings] + | isAbsDmd (demandInfo fn_info) + , not (isJoinId fn_id) + , Just filler <- mkAbsentFiller ww_opts fn_id + = return [(new_fn_id, filler)] - | isRecordSelector fn_id -- See Note [No worker/wrapper for record selectors] + -- See Note [Don't w/w INLINE things] + | hasInlineUnfolding fn_info + = return [(new_fn_id, rhs)] + + -- See Note [No worker/wrapper for record selectors] + | isRecordSelector fn_id = return [ (new_fn_id, rhs ) ] | is_fun && is_eta_exp - = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs + = splitFun ww_opts new_fn_id fn_info rhs - | isNonRec is_rec, is_thunk -- See Note [Thunk splitting] - = splitThunk dflags fam_envs is_rec new_fn_id rhs + -- See Note [Thunk splitting] + | isNonRec is_rec, is_thunk + = splitThunk ww_opts is_rec new_fn_id rhs | otherwise = return [ (new_fn_id, rhs) ] where - uf_opts = unfoldingOpts dflags - fn_info = idInfo fn_id - (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) - - cpr_ty = getCprSig (cprSigInfo fn_info) - -- Arity of the CPR sig should match idArity when it's not a join point. - -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal - cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info) - (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) - <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $ - ct_cpr cpr_ty + fn_info = idInfo fn_id + (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info) new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) -- See Note [Zapping DmdEnv after Demand Analyzer] and - -- See Note [Zapping Used Once info WorkWrap] + -- See Note [Zapping Used Once info in WorkWrap] - is_fun = notNull wrap_dmds || isJoinId fn_id - -- See Note [Don't eta expand in w/w] + -- is_eta_exp: see Note [Don't eta expand in w/w] is_eta_exp = length wrap_dmds == manifestArity rhs + is_fun = notNull wrap_dmds || isJoinId fn_id is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) && not (isUnliftedType (idType fn_id)) @@ -556,47 +570,56 @@ Note [Zapping Used Once info in WorkWrap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the used once info in demands and in -strictness signatures. +During the work/wrap pass, using zapIdUsedOnceInfo, we zap the "used once" info +* on every binder (let binders, case binders, lambda binders) +* in both demands and in strictness signatures +* recursively Why? * The simplifier may happen to transform code in a way that invalidates the data (see #11731 for an example). * It is not used in later passes, up to code generation. -So as the data is useless and possibly wrong, we want to remove it. The most -convenient place to do that is the worker wrapper phase, as it runs after every -run of the demand analyser besides the very last one (which is the one where we -want to _keep_ the info for the code generator). - -We do not do it in the demand analyser for the same reasons outlined in -Note [Zapping DmdEnv after Demand Analyzer] above. +At first it's hard to see how the simplifier might invalidate it (and +indeed for a while I thought it couldn't: #19482), but it's not quite +as simple as I thought. Consider this: + {-# STRICTNESS SIG #-} + f p = let v = case p of (a,b) -> a + in p `seq` (v,v) -For example, consider - let y = factorial v in - let x = y in - x + x +I think we'll give `f` the strictness signature ``, where the +`M` sayd that we'll evaluate the first component of the pair at most +once. Why? Because the RHS of the thunk `v` is evaluated at most +once. -Demand analysis will conclude, correctly, that `y` is demanded once. But if we inline `x` we get - let y = factorial v in - y + y +But now let's worker/wrapper f: + {-# STRICTNESS SIG #-} + $wf p1 = let p2 = absentError "urk" in + let p = (p1,p2) in + let v = case p of (a,b) -> a + in p `seq` (v,v) -Similarly for - f y = let x = y in x+x -where we will put a used-once demand on y, and hence also in f's demand signature. +where I've gotten the demand on `p1` by decomposing the P(M,A) argument demand. +This rapidly simplifies to + {-# STRICTNESS SIG #-} + $wf p1 = let v = p1 in + (v,v) -And recursively - f y = case y of (p,q) -> let p2 = p in p2+p2 - Here we'll get a used-once demand on p; but that is not robust to inlining p2. +and thence to `(p1,p1)` by inlining the trivial let. Now the demand on `p1` should +not be at most once!! -Conclusion: "demanded once" info is fragile. -* We want it after the final immediately-before-code-gen demand analysis, so we can identify single-entry thunks. -* But we don't want it otherwise because it is not robust. +Conclusion: used-once info is fragile to simplification, because of +the non-monotonic behaviour of let's, which turn used-many into +used-once. So indeed we should zap this info in worker/wrapper. -Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`. Both the *demand signature* of -the binder, and the *demand-info* of the binder. Moreover, do so recursively. +Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`. +Both the *demand signature* of the binder, and the *demand-info* of +the binder. Moreover, do so recursively. -(NB THE pre-code-gen demand analysis is not followed by worker/wrapper.) +You might wonder: why do we generate used-once info if we then throw +it away. The main reason is that we do a final run of the demand analyser, +immediately before CoreTidy, which is /not/ followed by worker/wrapper; it +is there only to generate used-once info for single-entry thunks. Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -605,7 +628,13 @@ for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression as RHS. -Performing the worker/wrapper split will implicitly eta-expand the binding to +Below is a historical account of what happened when w/w still did eta expansion. +Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing +a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg +(manifest arity). That's at least as terrible as doing eta expansion, so don't +do it. +--- +When worker/wrapper did eta expansion, it implictly eta expanded the binding to idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with divergence, it's also broken for newtypes: @@ -627,46 +656,94 @@ that we W/W'd for idArity and will propagate analysis information under that assumption. So far, this doesn't seem to matter in practice. See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. + +Note [Inline pragma for certainlyWillInline] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#19824 comment on 15 May 21): + f _ (x,y) = ...big... + v = ...big... + g x = f v x + 1 + +So `f` will generate a worker/wrapper split; and `g` (since it is small) +will trigger the certainlyWillInline case of splitFun. The danger is that +we end up with + g {- StableUnfolding = \x -> f v x + 1 -} + = ...blah... + +Since (a) that unfolding for g is AlwaysActive + (b) the unfolding for f's wrapper is ActiveAfterInitial +the call of f will never inline in g's stable unfolding, thereby +keeping `v` alive. + +I thought of changing g's unfolding to be ActiveAfterInitial, but that +too is bad: it delays g's inlining into other modules, which makes fewer +specialisations happen. Example in perf/should_run/DeriveNull. + +So I decided to live with the problem. In fact v's RHS will be replaced +by LitRubbish (see Note [Drop absent bindings]) so there is no great harm. -} --------------------- -splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr - -> UniqSM [(Id, CoreExpr)] -splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs - = warnPprTrace (not (wrap_dmds `lengthIs` arity)) (ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr)) $ - -- The arity should match the signature - do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info +splitFun :: WwOpts -> Id -> IdInfo -> CoreExpr -> UniqSM [(Id, CoreExpr)] +splitFun ww_opts fn_id fn_info rhs + = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) + (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ + do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds use_cpr_info ; case mb_stuff of - Nothing -> return [(fn_id, rhs)] + Nothing -> -- No useful wrapper; leave the binding alone + return [(fn_id, rhs)] - Just stuff -> do { work_uniq <- getUniqueM - ; return (mkWWBindPair dflags fn_id fn_info arity rhs - work_uniq div cpr stuff) } } + Just stuff + | Just stable_unf <- certainlyWillInline uf_opts fn_info + -- We could make a w/w split, but in fact the RHS is small + -- See Note [Don't w/w inline small non-loop-breaker things] + , let id_w_unf = fn_id `setIdUnfolding` stable_unf + -- See Note [Inline pragma for certainlyWillInline] + -> return [ (id_w_unf, rhs) ] + + | otherwise + -> do { work_uniq <- getUniqueM + ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body + work_uniq div cpr stuff) } } where - rhs_fvs = exprFreeVars rhs - arity = arityInfo fn_info - -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas + uf_opts = so_uf_opts (wo_simple_opts ww_opts) + (arg_vars, body) = collectBinders rhs + -- collectBinders was not enough for GHC.Event.IntTable.insertWith + -- last time I checked, where manifest lambdas were wrapped in casts + (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) + + cpr_ty = getCprSig (cprSigInfo fn_info) + -- Arity of the CPR sig should match idArity when it's not a join point. + -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal + cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info) + (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) + <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $ + ct_cpr cpr_ty + -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, -- see Note [Don't w/w join points for CPR]. use_cpr_info | isJoinId fn_id = topCpr | otherwise = cpr -mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity - -> CoreExpr -> Unique -> Divergence -> Cpr +mkWWBindPair :: WwOpts -> Id -> IdInfo + -> [Var] -> CoreExpr -> Unique -> Divergence -> Cpr -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) -> [(Id, CoreExpr)] -mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr +mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div cpr (work_demands, join_arity, wrap_fn, work_fn) = [(work_id, work_rhs), (wrap_id, wrap_rhs)] -- Worker first, because wrapper mentions it where - simpl_opts = initSimpleOpts dflags + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas - work_rhs = work_fn rhs + simpl_opts = wo_simple_opts ww_opts + + work_rhs = work_fn (mkLams fn_args fn_body) work_act = case fn_inline_spec of -- See Note [Worker activation] NoInline -> inl_act fn_inl_prag _ -> inl_act wrap_prag @@ -720,8 +797,9 @@ wrap_rhs = wrap_fn work_id wrap_prag = mkStrWrapperInlinePrag fn_inl_prag + wrap_unf = mkWrapperUnfolding simpl_opts wrap_rhs arity - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule simpl_opts wrap_rhs arity + wrap_id = fn_id `setIdUnfolding` wrap_unf `setInlinePragma` wrap_prag `setIdOccInfo` noOccInfo -- Zap any loop-breaker-ness, to avoid bleating from Lint @@ -729,7 +807,7 @@ fn_inl_prag = inlinePragInfo fn_info fn_inline_spec = inl_inline fn_inl_prag - fn_unfolding = unfoldingInfo fn_info + fn_unfolding = realUnfoldingInfo fn_info -- Even if we don't w/w join points for CPR, we might still do so for -- strictness. In which case a join point worker keeps its original CPR @@ -884,13 +962,13 @@ -- -- How can we do thunk-splitting on a top-level binder? See -- Note [Thunk splitting for top-level binders]. -splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] -splitThunk dflags fam_envs is_rec x rhs +splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk ww_opts is_rec x rhs = assert (not (isJoinId x)) $ do { let x' = localiseId x -- See comment above - ; (useful,_, wrap_fn, work_fn) - <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x'] - ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ] + ; (useful,_, wrap_fn, fn_arg) + <- mkWWstr_one ww_opts NotArgOfInlineableFun x' + ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ] ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive return res else return [(x, rhs)] } diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -8,58 +8,61 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Core.Opt.WorkWrap.Utils - ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs + ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs , DataConPatContext(..) , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg - , findTypeShape + , findTypeShape, mkAbsentFiller , isWorkerSmallEnough ) where import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Config (initSimpleOpts) + import GHC.Core -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase - , bindNonRec, dataConRepFSInstPat - , normSplitTyConApp_maybe, exprIsHNF ) -import GHC.Types.Id -import GHC.Types.Id.Info ( JoinArity ) +import GHC.Core.Utils import GHC.Core.DataCon -import GHC.Types.Demand -import GHC.Types.Cpr -import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, mkCoreApp, mkCoreLet - , mkWildValBinder ) -import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Builtin.Types ( tupleDataCon ) -import GHC.Types.Literal ( mkLitRubbish ) -import GHC.Types.Var.Env ( mkInScopeSet ) -import GHC.Types.Var.Set ( VarSet ) +import GHC.Core.Make +import GHC.Core.Subst import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred ) -import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe ) import GHC.Core.Coercion import GHC.Core.FamInstEnv -import GHC.Types.Basic ( Boxity(..) ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk +import GHC.Core.SimpleOpt( SimpleOpts ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Types.Var.Env +import GHC.Types.Basic import GHC.Types.Unique.Supply -import GHC.Types.Unique import GHC.Types.Name ( getOccFS ) + +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Data.List.SetOps + +import GHC.Builtin.Types ( tupleDataCon ) + import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Data.FastString -import GHC.Data.OrdList -import GHC.Data.List.SetOps +import GHC.Utils.Trace import Control.Applicative ( (<|>) ) import Control.Monad ( zipWithM ) import Data.List ( unzip4 ) +import GHC.Types.RepType + {- ************************************************************************ * * @@ -132,6 +135,7 @@ data WwOpts = MkWwOpts { wo_fam_envs :: !FamInstEnvs + , wo_simple_opts :: !SimpleOpts , wo_cpr_anal :: !Bool , wo_fun_to_thunk :: !Bool , wo_max_worker_args :: !Int @@ -141,6 +145,7 @@ initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts initWwOpts dflags fam_envs = MkWwOpts { wo_fam_envs = fam_envs + , wo_simple_opts = initSimpleOpts dflags , wo_cpr_anal = gopt Opt_CprAnal dflags , wo_fun_to_thunk = gopt Opt_FunToThunk dflags , wo_max_worker_args = maxWorkerArgs dflags @@ -156,46 +161,87 @@ nop_fn :: CoreExpr -> CoreExpr nop_fn body = body + mkWwBodies :: WwOpts - -> VarSet -- Free vars of RHS - -- See Note [Freshen WW arguments] - -> Id -- The original function - -> [Demand] -- Strictness of original function - -> Cpr -- Info about function result + -> Id -- ^ The original function + -> [Var] -- ^ Manifest args of original function + -> Type -- ^ Result type of the original function, + -- after being stripped of args + -> [Demand] -- ^ Strictness of original function + -> Cpr -- ^ Info about function result -> UniqSM (Maybe WwResult) - --- wrap_fn_args E = \x y -> E --- work_fn_args E = E x y - --- wrap_fn_str E = case x of { (a,b) -> --- case a of { (a1,a2) -> --- E a1 a2 b y }} --- work_fn_str E = \a1 a2 b y -> --- let a = (a1,a2) in --- let x = (a,b) in --- E +-- ^ Given a function definition +-- +-- > data T = MkT Int Bool Char +-- > f :: (a, b) -> Int -> T +-- > f = \x y -> E +-- +-- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@ +-- returns +-- +-- * The wrapper body context for the call to the worker function, lacking +-- only the 'Id' for the worker function: +-- +-- > W[_] :: Id -> CoreExpr +-- > W[work_fn] = \x y -> -- args of the wrapper (cloned_arg_vars) +-- > case x of (a, b) -> -- unbox wrapper args (wrap_fn_str) +-- > case y of I# n -> -- +-- > case a b n of -- call to the worker fun (call_work) +-- > (# i, b, c #) -> MkT i b c -- rebox result (wrap_fn_cpr) +-- +-- * The worker body context that wraps around its hole reboxing defns for x +-- and y, as well as returning CPR transit variables of the unboxed MkT +-- result in an unboxed tuple: +-- +-- > w[_] :: CoreExpr -> CoreExpr +-- > w[fn_rhs] = \a b n -> -- args of the worker (work_lam_args) +-- > let { y = I# n; x = (a, b) } in -- reboxing wrapper args (work_fn_str) +-- > case x y of -- call to the original RHS (call_rhs) +-- > MkT i b c -> (# i, b, c #) -- return CPR transit vars (work_fn_cpr) +-- +-- NB: The wrap_rhs hole is to be filled with the original wrapper RHS +-- @\x y -> E@. This is so that we can also use @w@ to transform stable +-- unfoldings, the lambda args of which may be different than x and y. +-- +-- * Id details for the worker function like demands on arguments and its join +-- arity. +-- +-- All without looking at E (except for beta reduction, see Note [Join points +-- and beta-redexes]), which allows us to apply the same split to function body +-- and its unfolding(s) alike. +-- +mkWwBodies opts fun_id arg_vars res_ty demands res_cpr + = do { massertPpr (filter isId arg_vars `equalLength` demands) + (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands) -mkWwBodies opts rhs_fvs fun_id demands cpr_info - = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) - -- See Note [Freshen WW arguments] + -- Clone and prepare arg_vars of the original fun RHS + -- See Note [Freshen WW arguments] + -- and Note [Zap IdInfo on worker args] + ; uniq_supply <- getUniqueSupplyM + ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars) + empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs) + zapped_arg_vars = map zap_var arg_vars + (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars + res_ty' = GHC.Core.Subst.substTy subst res_ty - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs empty_subst fun_ty demands - ; (useful1, work_args, wrap_fn_str, work_fn_str) - <- mkWWstr opts inlineable_flag wrap_args + ; (useful1, work_args, wrap_fn_str, fn_args) + <- mkWWstr opts inlineable_flag cloned_arg_vars -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr_entry opts res_ty cpr_info + <- mkWWcpr_entry opts res_ty' res_cpr ; let (work_lam_args, work_call_args) = mkWorkerArgs fun_id (wo_fun_to_thunk opts) work_args cpr_res_ty + call_work work_fn = mkVarApps (Var work_fn) work_call_args + call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args + -- See Note [Join points and beta-redexes] + wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work + worker_body = mkLams work_lam_args . work_fn_cpr . call_rhs worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] - wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var - worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args - && not (too_many_args_for_join_point wrap_args) + && not (too_many_args_for_join_point arg_vars) && ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, wrapper_body, worker_body)) @@ -209,7 +255,11 @@ -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent -- fw from being inlined into f's RHS where - fun_ty = idType fun_id + zap_var v | isTyVar v = v + | otherwise = modifyIdInfo zap_info v + zap_info info -- See Note [Zap IdInfo on worker args] + = info `setOccInfo` noOccInfo + mb_join_arity = isJoinId_maybe fun_id inlineable_flag -- See Note [Do not unpack class dictionaries] | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun @@ -218,8 +268,8 @@ -- Note [Do not split void functions] only_one_void_argument | [d] <- demands - , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty - , isAbsDmd d && isVoidTy arg_ty1 + , [v] <- filter isId arg_vars + , isAbsDmd d && isVoidTy (idType v) = True | otherwise = False @@ -235,6 +285,14 @@ | otherwise = False +-- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly. +-- PRECONDITION: The arg expressions are not free in any of the lambdas binders. +mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr +-- The precondition holds for our call site in mkWwBodies, because all the FVs +-- of as are either cloned_arg_vars (and thus fresh) or fresh worker args. +mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as +mkAppsBeta f as = mkApps f as + -- See Note [Limit w/w arity] isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool isWorkerSmallEnough max_worker_args old_n_args vars @@ -284,6 +342,20 @@ Still not very clever because it had a left-right bias. +Note [Zap IdInfo on worker args] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to zap the following IdInfo when re-using arg variables of the original +function for the worker: + + * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the + original fun body. Those occurrences will quickly cancel away with the lambdas + of the fun body in the next run of the Simplifier, but CoreLint will complain + in the meantime, so zap it. + +We zap in mkWwBodies because we need the zapped variables both when binding them +in mkWWstr (mkAbsentFiller, specifically) and in mkWorkerArgs, where we produce +the call to the fun body. + ************************************************************************ * * \subsection{Making wrapper args} @@ -329,7 +401,7 @@ -- Might the result be lifted? -- False => definitely lifted -- True => might be unlifted - -- We may encounter a levity-polymorphic result, in which case we + -- We may encounter a representation-polymorphic result, in which case we -- conservatively assume that we have laziness that needs -- preservation. See #15186. might_be_unlifted = case isLiftedType_maybe res_ty of @@ -410,143 +482,40 @@ FIXME Currently the functionality to produce "eta-contracted" wrappers is unimplemented; we simply give up. -************************************************************************ -* * -\subsection{Coercion stuff} -* * -************************************************************************ - -We really want to "look through" coerces. -Reason: I've seen this situation: - - let f = coerce T (\s -> E) - in \x -> case x of - p -> coerce T' f - q -> \s -> E2 - r -> coerce T' f - -If only we w/w'd f, we'd get - let f = coerce T (\s -> fw s) - fw = \s -> E - in ... - -Now we'll inline f to get - - let fw = \s -> E - in \x -> case x of - p -> fw - q -> \s -> E2 - r -> fw - -Now we'll see that fw has arity 1, and will arity expand -the \x to get what we want. --} - --- mkWWargs just does eta expansion --- is driven off the function type and arity. --- It chomps bites off foralls, arrows, newtypes --- and keeps repeating that until it's satisfied the supplied arity - -mkWWargs :: TCvSubst -- Freshening substitution to apply to the type - -- See Note [Freshen WW arguments] - -> Type -- The type of the function - -> [Demand] -- Demands and one-shot info for value arguments - -> UniqSM ([Var], -- Wrapper args - CoreExpr -> CoreExpr, -- Wrapper fn - CoreExpr -> CoreExpr, -- Worker fn - Type) -- Type of wrapper body - -mkWWargs subst fun_ty demands - | null demands - = return ([], nop_fn, nop_fn, substTy subst fun_ty) - - | (dmd:demands') <- demands - , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty) - id = mk_wrap_arg uniq arg_ty' dmd - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst fun_ty' demands' - ; return (id : wrap_args, - Lam id . wrap_fn_args, - apply_or_bind_then work_fn_args (varToCoreExpr id), - res_ty) } - - | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty - = do { uniq <- getUniqueM - ; let (subst', tv') = cloneTyVarBndr subst tv uniq - -- See Note [Freshen WW arguments] - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst' fun_ty' demands - ; return (tv' : wrap_args, - Lam tv' . wrap_fn_args, - apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), - res_ty) } - - | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty - -- The newtype case is for when the function has - -- a newtype after the arrow (rare) - -- - -- It's also important when we have a function returning (say) a pair - -- wrapped in a newtype, at least if CPR analysis can look - -- through such newtypes, which it probably can since they are - -- simply coerces. - - = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst rep_ty demands - ; let co' = substCo subst co - ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCo co'), - \e -> work_fn_args (Cast e co'), - res_ty) } - - | otherwise - = warnPprTrace True (ppr fun_ty) $ -- Should not happen: if there is a demand - return ([], nop_fn, nop_fn, substTy subst fun_ty) -- then there should be a function arrow - where - -- See Note [Join points and beta-redexes] - apply_or_bind_then k arg (Lam bndr body) - = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! - apply_or_bind_then k arg fun - = k $ mkCoreApp (text "mkWWargs") fun arg - -applyToVars :: [Var] -> CoreExpr -> CoreExpr -applyToVars vars fn = mkVarApps fn vars - -mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id -mk_wrap_arg uniq (Scaled w ty) dmd - = mkSysLocalOrCoVar (fsLit "w") uniq w ty - `setIdDemandInfo` dmd - -{- Note [Freshen WW arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wen we do a worker/wrapper split, we must not in-scope names as the arguments -of the worker, else we'll get name capture. E.g. - - -- y1 is in scope from further out - f x = ..y1.. +Note [Freshen WW arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we do a worker/wrapper split, we must freshen the arg vars of the original +fun RHS because they might shadow each other. E.g. -If we accidentally choose y1 as a worker argument disaster results: + f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int + f @a x @a y z = case x <|> y of + Nothing -> z + Just _ -> z + 1 - fww y1 y2 = let x = (y1,y2) in ...y1... + ==> {WW split unboxing the Int} -To avoid this: + $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int + $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz) - * We use a fresh unique for both type-variable and term-variable binders - Originally we lacked this freshness for type variables, and that led - to the very obscure #12562. (A type variable in the worker shadowed - an outer term-variable binding.) +(Notice that the code we actually emit will sort-of ANF-ise the lambda args, +leading to even more shadowing issues. The above demonstrates that even if we +try harder we'll still get shadowing issues.) - * Because of this cloning we have to substitute in the type/kind of the - new binders. That's why we carry the TCvSubst through mkWWargs. +What should we put in place for ??? ? Certainly not @a, because that would +reference the wrong, inner a. A similar situation occurred in #12562, we even +saw a type variable in the worker shadowing an outer term-variable binding. - So we need a decent in-scope set, just in case that type/kind - itself has foralls. We get this from the free vars of the RHS of the - function since those are the only variables that might be captured. - It's a lazy thunk, which will only be poked if the type/kind has a forall. +We avoid the issue by freshening the argument variables from the original fun +RHS through 'cloneBndrs', which will also take care of subsitution in binder +types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope +set, so that we don't need to do a FV traversal over the whole body of the +original function. - Another tricky case was when f :: forall a. a -> forall a. a->a - (i.e. with shadowing), and then the worker used the same 'a' twice. +At the moment, #12562 has no regression test. As such, this Note is not covered +by any test logic or when bootstrapping the compiler. Yet we clearly want to +freshen the binders, as the example above demonstrates. +Adding a Core pass that maximises shadowing for testing purposes might help, +see #17478. -} {- @@ -929,44 +898,43 @@ CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call -- and without its lambdas -- This fn adds the unboxing - - CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, - -- and lacking its lambdas. - -- This fn does the reboxing + [CoreExpr]) -- Reboxed args for the call to the + -- original RHS. Corresponds one-to-one + -- with the wrapper arg vars mkWWstr opts inlineable_flag args = go args where go_one arg = mkWWstr_one opts inlineable_flag arg - go [] = return (False, [], nop_fn, nop_fn) - go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg - ; (useful2, args2, wrap_fn2, work_fn2) <- go args + go [] = return (False, [], nop_fn, []) + go (arg : args) = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg + ; (useful2, args2, wrap_fn2, wrap_args) <- go args ; return ( useful1 || useful2 , args1 ++ args2 , wrap_fn1 . wrap_fn2 - , work_fn1 . work_fn2) } + , wrap_arg:wrap_args ) } ---------------------- --- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) --- * wrap_fn assumes wrap_arg is in scope, +-- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg) +-- * wrap_fn assumes wrap_var is in scope, -- brings into scope work_args (via cases) --- * work_fn assumes work_args are in scope, a --- brings into scope wrap_arg (via lets) +-- * wrap_arg assumes work_args are in scope, and builds a ConApp that +-- reconstructs the RHS of wrap_var that we pass to the original RHS -- See Note [Worker/wrapper for Strictness and Absence] mkWWstr_one :: WwOpts -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] -> Var - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr) mkWWstr_one opts inlineable_flag arg = case wantToUnboxArg fam_envs inlineable_flag arg_ty arg_dmd of _ | isTyVar arg -> do_nothing DropAbsent - | Just work_fn <- mk_absent_let opts arg + | Just absent_filler <- mkAbsentFiller opts arg -- Absent case. We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can - -- (that's what mk_absent_let does) - -> return (True, [], nop_fn, work_fn) + -- (that's what mkAbsentFiller does) + -> return (True, [], nop_fn, absent_filler) Unbox dcpc cs -> unbox_one_arg opts arg cs dcpc @@ -976,60 +944,50 @@ fam_envs = wo_fam_envs opts arg_ty = idType arg arg_dmd = idDemandInfo arg - do_nothing = return (False, [arg], nop_fn, nop_fn) + do_nothing = return (False, [arg], nop_fn, varToCoreExpr arg) unbox_one_arg :: WwOpts -> Var -> [Demand] -> DataConPatContext - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -unbox_one_arg opts arg cs + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr) +unbox_one_arg opts arg_var cs DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co } = do { pat_bndrs_uniqs <- getUniquesM - ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc + ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc (ex_tvs', arg_ids) = - dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args - arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs - unbox_fn = mkUnpackCase (Var arg) co (idMult arg) - dc (ex_tvs' ++ arg_ids') - arg_no_unf = zapStableUnfolding arg - -- See Note [Zap unfolding when beta-reducing] - -- in GHC.Core.Opt.Simplify; and see #13890 - rebox_fn = Let (NonRec arg_no_unf con_app) - con_app = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids') - ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } + dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args + arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs + unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) + dc (ex_tvs' ++ arg_ids') + ; (_, worker_args, wrap_fn, wrap_args) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids') + ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co + ; return (True, worker_args, unbox_fn . wrap_fn, wrap_arg) } -- Don't pass the arg, rebox instead --- | Tries to find a suitable dummy RHS to bind the given absent identifier to. +-- | Tries to find a suitable absent filler to bind the given absent identifier +-- to. See Note [Absent fillers]. -- --- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding --- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be --- found. -mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let opts arg +-- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the +-- same type as @id@. Otherwise, no suitable filler could be found. +mkAbsentFiller :: WwOpts -> Id -> Maybe CoreExpr +mkAbsentFiller opts arg -- The lifted case: Bind 'absentError' for a nice panic message if we are -- wrong (like we were in #11126). See (1) in Note [Absent fillers] - | Just [LiftedRep] <- mb_mono_prim_reps - , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers] - = Just (Let (NonRec arg panic_rhs)) + | not (isUnliftedType arg_ty) + , not is_strict, not is_evald -- See (2) in Note [Absent fillers] + = Just (mkAbsentErrorApp arg_ty msg) - -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@ + -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty` -- See Note [Absent fillers], the main part - | Just prim_reps <- mb_mono_prim_reps - = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty])) + | otherwise + = mkLitRubbish arg_ty - -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep. - -- See (3) in Note [Absent fillers] - | Nothing <- mb_mono_prim_reps - = warnPprTrace True (text "No absent value for" <+> ppr arg_ty) $ - Nothing where - arg_ty = idType arg - mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty - - panic_rhs = mkAbsentErrorApp arg_ty msg + arg_ty = idType arg + is_strict = isStrictDmd (idDemandInfo arg) + is_evald = isEvaldUnfolding $ idUnfolding arg msg = renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) @@ -1179,7 +1137,7 @@ Simplifier (when they are in fact *unreachable code*). Yet, we have to come up with "filler" values that we bind the absent arg Ids to. -That is exactly what Note [Rubbish values] are for: A convenient way to +That is exactly what Note [Rubbish literals] are for: A convenient way to conjure filler values at any type (and any representation or levity!). Needless to say, there are some wrinkles: @@ -1187,7 +1145,7 @@ 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk instead. If absence analysis was wrong (e.g., #11126) and the binding in fact is used, then we get a nice panic message instead of undefined - runtime behavior (See Modes of failure from Note [Rubbish values]). + runtime behavior (See Modes of failure from Note [Rubbish literals]). Obviously, we can't use an error-thunk if the value is of unlifted rep (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. @@ -1210,7 +1168,15 @@ cardinality 'C_10' (say, the arg to a bottoming function) where we could've used an error-thunk, but that's a small price to pay for simplicity. - 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g. + In #19766, we discovered that even if the binder has eval cardinality + 'C_00', it may end up in a strict field, with no surrounding seq + whatsoever! That happens if the calling code has already evaluated + said lambda binder, which will then have an evaluated unfolding + ('isEvaldUnfolding'). That in turn tells the Simplifier it is free to drop + the seq. So we better don't fill in an error-thunk for eval'd arguments + either, just in case it ends up in a strict field! + + 3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g. of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable. Why? Because if we don't know its representation (e.g. size in memory, register class), we don't know what or how much rubbish to emit in codegen. @@ -1304,7 +1270,7 @@ univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyCoVars dc subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs - arg_tys = map (substTy subst . scaledThing) (dataConRepArgTys dc) + arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) {- ************************************************************************ @@ -1331,17 +1297,16 @@ -- Part (1) res_bndr <- mk_res_bndr body_ty let bind_res_bndr body scope = mkDefaultCase body res_bndr scope - deref_res_bndr = Var res_bndr -- Part (2) - (useful, fromOL -> transit_vars, wrap_build_res, work_unpack_res) <- + (useful, fromOL -> transit_vars, rebuilt_result, work_unpack_res) <- mkWWcpr_one opts res_bndr body_cpr -- Part (3) let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars -- Stacking unboxer (work_fn) and builder (wrap_fn) together - let wrap_fn = unbox_transit_tup (wrap_build_res deref_res_bndr) -- 3 2 1 + let wrap_fn = unbox_transit_tup rebuilt_result -- 3 2 work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3 work_body_ty = exprType transit_tup return $ if not useful @@ -1360,68 +1325,67 @@ -- -- 1. A Bool capturing whether the transformation did anything useful. -- 2. The list of transit variables (see the Note). --- 3. The result builder expression for the wrapper. 'nop_fn' if not useful. +-- 3. The result builder expression for the wrapper. The original case binder if not useful. -- 4. The result unpacking expression for the worker. 'nop_fn' if not useful. -type CprWwResult = (Bool, OrdList Var, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +type CprWwResultOne = (Bool, OrdList Var, CoreExpr , CoreExpr -> CoreExpr) +type CprWwResultMany = (Bool, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr) -mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResult +mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany mkWWcpr _opts vars [] = -- special case: No CPRs means all top (for example from FlatConCpr), -- hence stop WW. - return (False, toOL vars, nop_fn, nop_fn) + return (False, toOL vars, map varToCoreExpr vars, nop_fn) mkWWcpr opts vars cprs = do -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that. massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs) massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs) - (usefuls, varss, wrap_build_ress, work_unpack_ress) <- + (usefuls, varss, rebuilt_results, work_unpack_ress) <- unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs return ( or usefuls , concatOL varss - , foldl' (.) nop_fn wrap_build_ress + , rebuilt_results , foldl' (.) nop_fn work_unpack_ress ) -mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResult +mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne -- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. mkWWcpr_one opts res_bndr cpr | assert (not (isTyVar res_bndr) ) True , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr = unbox_one_result opts res_bndr arg_cprs dcpc | otherwise - = return (False, unitOL res_bndr, nop_fn, nop_fn) + = return (False, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) unbox_one_result - :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResult + :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne -- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR] unbox_one_result opts res_bndr arg_cprs DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co } = do - -- unboxer (free in `res_bndr`): | builder (binds `res_bndr`): - -- ( case res_bndr of (i, j) -> ) | ( let j = I# b in ) - -- ( case i of I# a -> ) | ( let i = I# a in ) - -- ( case j of I# b -> ) | ( let res_bndr = (i, j) in ) - -- ( ) | ( ) + -- unboxer (free in `res_bndr`): | builder (where builds what was + -- ( case res_bndr of (i, j) -> ) | bound to i) + -- ( case i of I# a -> ) | + -- ( case j of I# b -> ) | ( (, ) ) + -- ( ) | pat_bndrs_uniqs <- getUniquesM let (_exs, arg_ids) = dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args massert (null _exs) -- Should have been caught by wantToUnboxResult - let -- con_app = (C a b |> sym co) - con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co - -- this_wrap_build_res body = (let res_bndr = C a b |> sym co in [r]) - this_wrap_build_res = Let (NonRec res_bndr con_app) + (nested_useful, transit_vars, con_args, work_unbox_res) <- + mkWWcpr opts arg_ids arg_cprs + + let -- rebuilt_result = (C a b |> sym co) + rebuilt_result = mkConApp dc (map Type tc_args ++ con_args) `mkCast` mkSymCo co -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> [a,b]) this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids - (nested_useful, transit_vars, wrap_build_res, work_unbox_res) <- - mkWWcpr opts arg_ids arg_cprs - -- Don't try to WW an unboxed tuple return type when there's nothing inside -- to unbox further. return $ if isUnboxedTupleDataCon dc && not nested_useful - then ( False, unitOL res_bndr, nop_fn, nop_fn ) + then ( False, unitOL res_bndr, Var res_bndr, nop_fn ) else ( True , transit_vars - , wrap_build_res . this_wrap_build_res + , rebuilt_result , this_work_unbox_res . work_unbox_res ) @@ -1482,10 +1446,7 @@ * A result-building expression for the wrapper, with a hole for the worker call: ``` build wkr_call = ( case of (# a, b #) -> ) -- (3) - ( let j = I# b in ) -- (2) - ( let i = I# a in ) -- (2) - ( let r = (i, j) in ) -- (2) - ( r ) -- (1) + ( (I# a, I# b) ) -- (2) ``` * The result type of the worker, e.g., `(# Int#, Int# #)` above. diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -17,42 +17,46 @@ import GHC.Prelude +import GHC.Driver.Session + import GHC.Core import GHC.Core.Utils ( exprType, findDefault, isJoinBind , exprIsTickedString_maybe ) import GHC.Core.Opt.Arity ( manifestArity ) +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon + import GHC.Stg.Syntax import GHC.Stg.Debug -import GHC.Core.Type import GHC.Types.RepType -import GHC.Core.TyCon import GHC.Types.Id.Make ( coercionTokenId ) import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Core.DataCon import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Env -import GHC.Unit.Module import GHC.Types.Name ( isExternalName, nameModule_maybe ) import GHC.Types.Basic ( Arity ) -import GHC.Builtin.Types ( unboxedUnitDataCon ) import GHC.Types.Literal +import GHC.Types.ForeignCall +import GHC.Types.IPE +import GHC.Types.Demand ( isUsedOnceDmd ) +import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) + +import GHC.Unit.Module +import GHC.Builtin.Types ( unboxedUnitDataCon ) +import GHC.Data.FastString +import GHC.Platform.Ways +import GHC.Builtin.PrimOps ( PrimCall(..) ) + import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Misc (HasDebugCallStack) -import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Driver.Session -import GHC.Platform.Ways -import GHC.Driver.Ppr -import GHC.Types.ForeignCall -import GHC.Types.IPE -import GHC.Types.Demand ( isUsedOnceDmd ) -import GHC.Builtin.PrimOps ( PrimCall(..) ) -import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) +import GHC.Utils.Trace import Control.Monad (ap) import Data.Maybe (fromMaybe) @@ -395,9 +399,11 @@ coreToStgExpr expr@(App _ _) = case app_head of - Var f -> coreToStgApp f args ticks -- Regular application - Lit l@LitRubbish{} -> return (StgLit l) -- LitRubbish - _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr) + Var f -> coreToStgApp f args ticks -- Regular application + Lit l | isLitRubbish l -- If there is LitRubbish at the head, + -> return (StgLit l) -- discard the arguments + + _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr) where (app_head, args, ticks) = myCollectArgs expr coreToStgExpr expr@(Lam _ _) 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 @@ -20,7 +20,6 @@ import GHC.Prelude import GHC.Platform -import GHC.Platform.Ways import GHC.Driver.Session import GHC.Driver.Env @@ -33,7 +32,6 @@ import GHC.Builtin.PrimOps import GHC.Builtin.Types import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) -import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId ) import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -49,10 +47,10 @@ import GHC.Core.Opt.OccurAnal import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) - import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.FastString +import GHC.Data.Pair import GHC.Utils.Error import GHC.Utils.Misc @@ -61,6 +59,7 @@ import GHC.Utils.Outputable import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Logger +import GHC.Utils.Trace import GHC.Types.Demand import GHC.Types.Var @@ -68,20 +67,18 @@ import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId ) import GHC.Types.Basic 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.CostCentre ( CostCentre, ccFromThisModule ) import GHC.Types.Unique.Supply -import GHC.Data.Pair import Data.List ( unfoldr ) import Data.Functor.Identity import Control.Monad -import qualified Data.Set as S {- -- --------------------------------------------------------------------------- @@ -241,20 +238,15 @@ -} corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] - -> IO (CoreProgram, S.Set CostCentre) + -> IO CoreProgram corePrepPgm hsc_env this_mod mod_loc binds data_tycons = - withTiming logger dflags + withTiming logger (text "CorePrep"<+>brackets (ppr this_mod)) - (\(a,b) -> a `seqList` b `seq` ()) $ do + (\a -> a `seqList` ()) $ do us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env - let cost_centres - | WayProf `S.member` ways dflags - = collectCostCentres this_mod binds - | otherwise - = S.empty - + let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons -- NB: we must feed mkImplicitBinds through corePrep too -- so that they are suitably cloned and eta-expanded @@ -265,20 +257,19 @@ return (deFloatTop (floats1 `appendFloats` floats2)) endPassIO hsc_env alwaysQualify CorePrep binds_out [] - return (binds_out, cost_centres) + return binds_out where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - withTiming logger dflags (text "CorePrep [expr]") (\e -> e `seq` ()) $ do + withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats @@ -2121,41 +2112,6 @@ wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) ------------------------------------------------------------------------------- --- Collecting cost centres --- --------------------------------------------------------------------------- - --- | Collect cost centres defined in the current module, including those in --- unfoldings. -collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre -collectCostCentres mod_name - = foldl' go_bind S.empty - where - go cs e = case e of - Var{} -> cs - Lit{} -> cs - App e1 e2 -> go (go cs e1) e2 - Lam _ e -> go cs e - Let b e -> go (go_bind cs b) e - Case scrt _ _ alts -> go_alts (go cs scrt) alts - Cast e _ -> go cs e - Tick (ProfNote cc _ _) e -> - go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e - Tick _ e -> go cs e - Type{} -> cs - Coercion{} -> cs - - go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e) - - go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre - go_bind cs (NonRec b e) = - go (maybe cs (go cs) (get_unf b)) e - go_bind cs (Rec bs) = - foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs - - -- Unfoldings may have cost centres that in the original definion are - -- optimized away, see #5889. - get_unf = maybeUnfoldingTemplate . realIdUnfolding ------------------------------------------------------------------------------ diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -21,7 +21,8 @@ -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Diagnostic import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr @@ -50,6 +51,7 @@ import GHC.Types.Unique.DSet import GHC.Utils.Outputable +import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Error @@ -58,7 +60,6 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.External -import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.Graph import GHC.Unit.Module.ModSummary @@ -94,12 +95,13 @@ -- Apply options from file to dflags dflags0 <- getDynFlags let dflags1 = dflags0 - src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename + let parser_opts1 = initParserOpts dflags1 + src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts - modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) + modifySession (hscSetFlags dflags) -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ handleFlagWarnings logger dflags warns + liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename @@ -177,13 +179,14 @@ , not (null insts) = sub_comp (key_base p) uid_str | otherwise = sub_comp (key_base p) - mk_temp_env hsc_env = hsc_env - { hsc_dflags = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env) - } + mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env mk_temp_dflags unit_state dflags = dflags { backend = case session_type of TcSession -> NoBackend _ -> backend dflags + , ghcLink = case session_type of + TcSession -> NoLink + _ -> ghcLink dflags , homeUnitInstantiations_ = insts -- if we don't have any instantiation, don't -- fill `homeUnitInstanceOfId` as it makes no @@ -333,7 +336,7 @@ linkables = map (expectJust "bkp link" . hm_linkable) . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) $ home_mod_infos - getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables state = hsc_units hsc_env @@ -439,10 +442,7 @@ , ue_units = unit_state , ue_unit_dbs = Just dbs } - setSession $ hsc_env - { hsc_dflags = dflags - , hsc_unit_env = unit_env - } + setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do @@ -540,10 +540,10 @@ -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO () -backpackProgressMsg level logger dflags msg = - compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr - <> msg +backpackProgressMsg :: Int -> Logger -> SDoc -> IO () +backpackProgressMsg level logger msg = + compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr + <> msg -- | Creates a 'Messager' for Backpack compilation; this is basically -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which @@ -556,7 +556,7 @@ logger = hsc_logger hsc_env state = hsc_units hsc_env showMsg msg reason = - backpackProgressMsg level logger dflags $ pprWithUnitState state $ + backpackProgressMsg level logger $ pprWithUnitState state $ showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node <> reason @@ -589,21 +589,19 @@ -- | Message when we initially process a Backpack unit. msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do - dflags <- getDynFlags logger <- getLogger level <- getBkpLevel - liftIO . backpackProgressMsg level logger dflags + liftIO . backpackProgressMsg level logger $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn -- | Message when we instantiate a Backpack unit. msgUnitId :: Unit -> BkpM () msgUnitId pk = do - dflags <- getDynFlags logger <- getLogger hsc_env <- getSession level <- getBkpLevel let state = hsc_units hsc_env - liftIO . backpackProgressMsg level logger dflags + liftIO . backpackProgressMsg level logger $ pprWithUnitState state $ text "Instantiating " <> withPprStyle backpackStyle (ppr pk) @@ -611,12 +609,11 @@ -- | Message when we include a Backpack unit. msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do - dflags <- getDynFlags logger <- getLogger hsc_env <- getSession level <- getBkpLevel let state = hsc_units hsc_env - liftIO . backpackProgressMsg level logger dflags + liftIO . backpackProgressMsg level logger $ pprWithUnitState state $ showModuleIndex (i, n) <> text "Including " <> withPprStyle backpackStyle (ppr uid) @@ -751,7 +748,7 @@ (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) + src_hash <- liftIO $ getFileHash (bkp_filename env) hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) @@ -765,8 +762,9 @@ ms_mod = mod, ms_hsc_src = HsigFile, ms_location = location, - ms_hs_date = time, + ms_hs_hash = src_hash, ms_obj_date = Nothing, + ms_dyn_obj_date = Nothing, ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp, ms_srcimps = [], @@ -802,7 +800,6 @@ emptyModNodeMap -- GHC API recomp not supported (hscSourceToIsBoot hsc_src) lmodname - True -- Target lets you disallow, but not here Nothing -- GHC API buffer support not supported [] -- No exclusions case r of @@ -849,7 +846,7 @@ _ -> location0 -- This duplicates a pile of logic in GHC.Driver.Make env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) + src_hash <- liftIO $ getFileHash (bkp_filename env) hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) @@ -898,8 +895,9 @@ hpm_module = hsmod, hpm_src_files = [] -- TODO if we preprocessed it }), - ms_hs_date = time, + ms_hs_hash = src_hash, ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp } diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -27,6 +27,7 @@ import GHC.Cmm.CLabel import GHC.Driver.Session +import GHC.Driver.Config.CmmToAsm (initNCGConfig) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -42,9 +43,9 @@ import GHC.Utils.Panic import GHC.Utils.Logger import GHC.Utils.Exception (bracket) +import GHC.Utils.Ppr (Mode(..)) import GHC.Unit -import GHC.Unit.State import GHC.Unit.Finder ( mkStubPaths ) import GHC.Types.SrcLoc @@ -92,16 +93,14 @@ else cmm_stream do_lint cmm = withTimingSilent logger - dflags (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of - Just err -> do { putLogMsg logger - dflags + Just err -> do { logMsg logger MCDump noSrcSpan $ withPprStyle defaultDumpStyle err - ; ghcExit logger dflags 1 + ; ghcExit logger 1 } Nothing -> return () ; return cmm @@ -137,7 +136,7 @@ -> [UnitId] -> IO a outputC logger dflags filenm cmm_stream packages = - withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do let pkg_names = map unitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -145,11 +144,12 @@ let platform = targetPlatform dflags writeC cmm = do let doc = cmmToC platform cmm - dumpIfSet_dyn logger dflags Opt_D_dump_c_backend + putDumpFileMaybe logger Opt_D_dump_c_backend "C backend output" FormatC doc - printForC dflags h doc + let ctx = initSDocContext dflags (PprCode CStyle) + printSDocLn ctx LeftMode h doc Stream.consume cmm_stream id writeC {- @@ -169,10 +169,11 @@ -> IO a outputAsm logger dflags this_mod location filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm) + debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm) + let ncg_config = initNCGConfig dflags this_mod {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream + nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream {- ************************************************************************ @@ -226,7 +227,7 @@ createDirectoryIfMissing True (takeDirectory stub_h) - dumpIfSet_dyn logger dflags Opt_D_dump_foreign + putDumpFileMaybe logger Opt_D_dump_foreign "Foreign export header file" FormatC stub_h_output_d @@ -251,7 +252,7 @@ <- outputForeignStubs_help stub_h stub_h_output_w ("#include \n" ++ cplusplus_hdr) cplusplus_ftr - dumpIfSet_dyn logger dflags Opt_D_dump_foreign + putDumpFileMaybe logger Opt_D_dump_foreign "Foreign export stubs" FormatC stub_c_output_d stub_c_file_exists diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -0,0 +1,70 @@ +module GHC.Driver.Config.CmmToAsm + ( initNCGConfig + ) +where + +import GHC.Prelude + +import GHC.Driver.Session + +import GHC.Platform +import GHC.Unit.Types (Module) +import GHC.CmmToAsm.Config +import GHC.Utils.Outputable + +-- | Initialize the native code generator configuration from the DynFlags +initNCGConfig :: DynFlags -> Module -> NCGConfig +initNCGConfig dflags this_mod = NCGConfig + { ncgPlatform = targetPlatform dflags + , ncgThisModule = this_mod + , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle) + , ncgProcAlignment = cmmProcAlignment dflags + , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , ncgPIC = positionIndependent dflags + , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags + , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags + , ncgSplitSections = gopt Opt_SplitSections dflags + , ncgRegsIterative = gopt Opt_RegsIterative dflags + , ncgRegsGraph = gopt Opt_RegsGraph dflags + , ncgAsmLinting = gopt Opt_DoAsmLinting dflags + , ncgCfgWeights = cfgWeights dflags + , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags + , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags + + -- With -O1 and greater, the cmmSink pass does constant-folding, so + -- we don't need to do it again in the native code generator. + , ncgDoConstantFolding = optLevel dflags < 1 + + , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags + , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags + , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags + , ncgBmiVersion = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags + ArchX86 -> bmiVersion dflags + _ -> Nothing + + -- We assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + , ncgSseVersion = + let v | sseVersion dflags < Just SSE2 = Just SSE2 + | otherwise = sseVersion dflags + in case platformArch (targetPlatform dflags) of + ArchX86_64 -> v + ArchX86 -> v + _ -> Nothing + + , ncgDwarfEnabled = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64 + , ncgDwarfUnwindings = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 + , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1. + , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 + , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags + , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags + , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags + , ncgComputeUnwinding = debugLevel dflags > 0 + } 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 @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -88,6 +89,7 @@ , ioMsgMaybe , showModuleIndex , hscAddSptEntries + , writeInterfaceOnlyMode ) where import GHC.Prelude @@ -99,7 +101,9 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput -import GHC.Driver.Config +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Diagnostic import GHC.Driver.Hooks import GHC.Runtime.Context @@ -174,7 +178,6 @@ import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.External -import GHC.Unit.State import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface @@ -218,6 +221,7 @@ import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) +import qualified GHC.SysTools import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) @@ -247,7 +251,7 @@ tmpfs <- initTmpFs unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags) return HscEnv { hsc_dflags = dflags - , hsc_logger = logger + , hsc_logger = setLogFlags logger (initLogFlags dflags) , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags @@ -278,10 +282,10 @@ handleWarnings :: Hsc () handleWarnings = do - dflags <- getDynFlags + diag_opts <- initDiagOpts <$> getDynFlags logger <- getLogger w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger dflags w + liftIO $ printOrThrowDiagnostics logger diag_opts w clearDiagnostics -- | log warning in the monad, and if there are errors then @@ -295,11 +299,11 @@ -- contain at least one error (e.g. coming from PFailed) handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do - dflags <- getDynFlags + diag_opts <- initDiagOpts <$> getDynFlags logDiagnostics (GhcPsMessage <$> warnings) logger <- getLogger let (wWarns, wErrs) = partitionMessages warnings - liftIO $ printMessages logger dflags wWarns + liftIO $ printMessages logger diag_opts wWarns throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs -- | Deal with errors and warnings returned by a compilation step @@ -388,7 +392,7 @@ | otherwise = do dflags <- getDynFlags logger <- getLogger - {-# SCC "Parser" #-} withTiming logger dflags + {-# SCC "Parser" #-} withTiming logger (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) (const ()) $ do let src_filename = ms_hspp_file mod_summary @@ -413,13 +417,13 @@ POk pst rdr_module -> do let (warns, errs) = getMessages pst logDiagnostics (GhcPsMessage <$> warns) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rdr_module) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" + liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) @@ -469,7 +473,7 @@ dflags <- getDynFlags logger <- getLogger - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer" + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) -- Create HIE files @@ -479,7 +483,7 @@ hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) let out_file = ml_hie_file $ ms_location mod_summary liftIO $ writeHieFile out_file hieFile - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do @@ -487,18 +491,19 @@ liftIO $ do -- Validate Scopes case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of - [] -> putMsg logger dflags $ text "Got valid scopes" + [] -> putMsg logger $ text "Got valid scopes" xs -> do - putMsg logger dflags $ text "Got invalid scopes" - mapM_ (putMsg logger dflags) xs + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs -- Roundtrip testing file' <- readHieFile (hsc_NC hs_env) out_file case diffFile hieFile (hie_file_result file') of [] -> - putMsg logger dflags $ text "Got no roundtrip errors" + putMsg logger $ text "Got no roundtrip errors" xs -> do - putMsg logger dflags $ text "Got roundtrip errors" - mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs return rn_info @@ -544,7 +549,7 @@ Nothing -> hscParse' mod_summary tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile - then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary Nothing ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 @@ -558,14 +563,15 @@ -> Hsc TcGblEnv tcRnModule' sum save_rn_syntax mod = do hsc_env <- getHscEnv - dflags <- getDynFlags + dflags <- getDynFlags let reason = WarningWithFlag Opt_WarnMissingSafeHaskellMode + let diag_opts = initDiagOpts dflags -- -Wmissing-safe-haskell-mode when (not (safeHaskellModeEnabled dflags) && wopt Opt_WarnMissingSafeHaskellMode dflags) $ logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $ + mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainDiagnostic reason noHints warnMissingSafeHaskellMode @@ -595,14 +601,14 @@ True | safeHaskell dflags == Sf_Safe -> return () | otherwise -> (logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $ + mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) noHints $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> (logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $ + mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) noHints $ errTwthySafe tcg_res') @@ -630,8 +636,8 @@ -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. -makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails -makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result +makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails +makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result {- ********************************************************************** @@ -680,15 +686,17 @@ type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () -- | Do the recompilation avoidance checks for both one-shot and --make modes +-- This function is the *only* place in the compiler where we decide whether to +-- recompile a module or not! hscRecompStatus :: Maybe Messager -> HscEnv -> ModSummary - -> SourceModified -> Maybe ModIface + -> Maybe Linkable -> (Int,Int) -> IO HscRecompStatus hscRecompStatus - mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index + mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index = do let msg what = case mHscMessage of @@ -696,25 +704,87 @@ Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary)) Nothing -> return () - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_modified mb_old_iface - + -- First check to see if the interface file agrees with the + -- source file. + (recomp_iface_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary mb_old_iface + -- Check to see whether the expected build products already exist. + -- If they don't exists then we trigger recompilation. + let lcl_dflags = ms_hspp_opts mod_summary + (recomp_obj_reqd, mb_linkable) <- + case () of + -- No need for a linkable, we're good to go + _ | writeInterfaceOnlyMode lcl_dflags -> return (UpToDate, Nothing) + -- Interpreter can use either already loaded bytecode or loaded object code + | not (backendProducesObject (backend lcl_dflags)) -> do + res <- liftIO $ checkByteCode old_linkable + case res of + (_, Just{}) -> return res + _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary + -- Need object files for making object files + | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary + | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) + let recomp_reqd = recomp_iface_reqd `mappend` recomp_obj_reqd -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk. let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface - msg recomp_reqd case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> do - -- We didn't need to do any typechecking; the old interface - -- file on disk was good enough. - return $ HscUpToDate iface + Just iface | not (recompileRequired recomp_reqd) -> + return $ HscUpToDate iface mb_linkable + _ -> + return $ HscRecompNeeded mb_old_hash - _ -> return $ HscRecompNeeded mb_old_hash +-- | Check that the .o files produced by compilation are already up-to-date +-- or not. +checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (RecompileRequired, Maybe Linkable) +checkObjects dflags mb_old_linkable summary = do + dt_state <- dynamicTooState dflags + let + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_dyn_obj_date = ms_dyn_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + -- dynamic-too *also* produces the dyn_o_file, so have to check + -- that's there, and if it's not, regenerate both .o and + -- .dyn_o + checkDynamicObj k = case dt_state of + DT_OK -> case (>=) <$> mb_dyn_obj_date <*> mb_if_date of + Just True -> k + _ -> return (RecompBecause "Missing dynamic object", Nothing) + -- Not in dynamic-too mode + _ -> k + checkDynamicObj $ + case (,) <$> mb_obj_date <*> mb_if_date of + Just (obj_date, if_date) + | obj_date >= if_date -> + case mb_old_linkable of + Just old_linkable + | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date + -> return $ (UpToDate, Just old_linkable) + _ -> (UpToDate,) . Just <$> findObjectLinkable this_mod obj_fn obj_date + _ -> return (RecompBecause "Missing object file", Nothing) + +-- | Check to see if we can reuse the old linkable, by this point we will +-- have just checked that the old interface matches up with the source hash, so +-- no need to check that again here +checkByteCode :: Maybe Linkable -> IO (RecompileRequired, Maybe Linkable) +checkByteCode mb_old_linkable = + case mb_old_linkable of + Just old_linkable + | not (isObjectLinkable old_linkable) + -> return $ (UpToDate, Just old_linkable) + _ -> return $ (RecompBecause "Missing bytecode", Nothing) + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + + -- Knot tying! See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails @@ -796,6 +866,7 @@ logger <- getLogger let bcknd = backend dflags hsc_src = ms_hsc_src summary + diag_opts = initDiagOpts dflags -- Desugar, if appropriate -- @@ -810,7 +881,7 @@ -- Report the warnings from both typechecking and desugar together w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger dflags (unionMessages tc_warnings w) + liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w) clearDiagnostics -- Simplify, if appropriate, and (whether we simplified or not) generate an @@ -828,7 +899,7 @@ {-# SCC "GHC.Driver.Main.mkPartialIface" #-} -- This `force` saves 2M residency in test T10370 -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env details simplified_guts) + force (mkPartialIface hsc_env details summary simplified_guts) return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary, @@ -840,7 +911,7 @@ -- and generate a simple interface. _ -> do (iface, mb_old_iface_hash, _details) <- liftIO $ - hscSimpleIface hsc_env tc_result mb_old_hash + hscSimpleIface hsc_env tc_result summary mb_old_hash liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary) @@ -911,12 +982,13 @@ write_iface dflags' iface = let !iface_name = buildIfName (hiSuf dflags') + profile = targetProfile dflags' in {-# SCC "writeIface" #-} - withTiming logger dflags' + withTiming logger (text "WriteIface"<+>brackets (text iface_name)) (const ()) - (writeIface logger dflags' iface_name iface) + (writeIface logger profile iface_name iface) when (write_interface || force_write_interface) $ do @@ -937,7 +1009,7 @@ dt <- dynamicTooState dflags - when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $ + when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ hang (text "Writing interface(s):") 2 $ vcat [ text "Kind:" <+> if is_simple then text "simple" else text "full" , text "Hash change:" <+> ppr (not no_change) @@ -960,6 +1032,22 @@ DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface _ -> return () + when (gopt Opt_WriteHie dflags) $ do + -- This is slightly hacky. A hie file is considered to be up to date + -- if its modification time on disk is greater than or equal to that + -- of the .hi file (since we should always write a .hi file if we are + -- writing a .hie file). However, with the way this code is + -- structured at the moment, the .hie file is often written before + -- the .hi file; by touching the file here, we ensure that it is + -- correctly considered up-to-date. + -- + -- The file should exist by the time we get here, but we check for + -- existence just in case, so that we don't accidentally create empty + -- .hie files. + let hie_file = ml_hie_file mod_location + whenM (doesFileExist hie_file) $ + GHC.SysTools.touch logger dflags "Touching hie file" hie_file + -------------------------------------------------------------- -- NoRecomp handlers -------------------------------------------------------------- @@ -977,17 +1065,11 @@ -- Progress displayers. -------------------------------------------------------------- -oneShotMsg :: HscEnv -> RecompileRequired -> IO () -oneShotMsg hsc_env recomp = +oneShotMsg :: Logger -> RecompileRequired -> IO () +oneShotMsg logger recomp = case recomp of - UpToDate -> - compilationProgressMsg logger dflags $ - text "compilation IS NOT required" - _ -> - return () - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env + UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" + _ -> return () batchMsg :: Messager batchMsg hsc_env mod_index recomp node = case node of @@ -995,21 +1077,21 @@ case recomp of MustCompile -> showMsg (text "Instantiating ") empty UpToDate - | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty + | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty | otherwise -> return () RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]") ModuleNode _ -> case recomp of MustCompile -> showMsg (text "Compiling ") empty UpToDate - | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty + | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty | otherwise -> return () RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]") where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env showMsg msg reason = - compilationProgressMsg logger dflags $ + compilationProgressMsg logger $ (showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node) <> reason @@ -1075,25 +1157,26 @@ where checkRULES dflags tcg_env' = - case safeLanguageOn dflags of + let diag_opts = initDiagOpts dflags + in case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logDiagnostics $ fmap GhcDriverMessage $ warns dflags (tcg_rules tcg_env') + logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env') -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' - warns dflags rules = mkMessages $ listToBag $ map (warnRules dflags) rules + warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules - warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage - warnRules df (L loc (HsRule { rd_name = n })) = - mkPlainMsgEnvelope df (locA loc) $ + warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage + warnRules diag_opts (L loc (HsRule { rd_name = n })) = + mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ @@ -1239,6 +1322,7 @@ hsc_env <- getHscEnv dflags <- getDynFlags iface <- lookup' m + let diag_opts = initDiagOpts dflags case iface of -- can't load iface to check trust! Nothing -> throwOneError $ @@ -1261,7 +1345,7 @@ warns = if wopt Opt_WarnInferredSafeImports dflags && safeLanguageOn dflags && trust == Sf_SafeInferred - then inferredImportWarn dflags + then inferredImportWarn diag_opts else emptyMessages -- General errors we throw but Safe errors we log errs = case (safeM, safeP) of @@ -1275,8 +1359,8 @@ where state = hsc_units hsc_env - inferredImportWarn dflags = singleMessage - $ mkMsgEnvelope dflags l (pkgQual state) + inferredImportWarn diag_opts = singleMessage + $ mkMsgEnvelope diag_opts l (pkgQual state) $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) noHints $ sep @@ -1371,9 +1455,10 @@ dflags <- getDynFlags let reason = WarningWithFlag Opt_WarnUnsafe - when (wopt Opt_WarnUnsafe dflags) + let diag_opts = initDiagOpts dflags + when (diag_wopt Opt_WarnUnsafe diag_opts) (logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $ + mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainDiagnostic reason noHints $ whyUnsafe' dflags) @@ -1435,9 +1520,9 @@ hsc_env <- getHscEnv hsc_env_with_plugins <- if null plugins -- fast path then return hsc_env - else liftIO $ initializePlugins $ hsc_env - { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins - } + else liftIO $ flip initializePlugins (Just $ mg_mnwib ds_result) + $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins) + hsc_env {-# SCC "Core2Core" #-} liftIO $ core2core hsc_env_with_plugins ds_result @@ -1449,22 +1534,25 @@ -- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] hscSimpleIface :: HscEnv -> TcGblEnv + -> ModSummary -> Maybe Fingerprint -> IO (ModIface, Maybe Fingerprint, ModDetails) -hscSimpleIface hsc_env tc_result mb_old_iface - = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface +hscSimpleIface hsc_env tc_result summary mb_old_iface + = runHsc hsc_env $ hscSimpleIface' tc_result summary mb_old_iface hscSimpleIface' :: TcGblEnv + -> ModSummary -> Maybe Fingerprint -> Hsc (ModIface, Maybe Fingerprint, ModDetails) -hscSimpleIface' tc_result mb_old_iface = do +hscSimpleIface' tc_result summary mb_old_iface = do hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + logger <- getLogger + details <- liftIO $ mkBootModDetailsTc logger tc_result safe_mode <- hscGetSafeMode tc_result new_iface <- {-# SCC "MkFinalIface" #-} liftIO $ - mkIfaceTc hsc_env safe_mode details tc_result + mkIfaceTc hsc_env safe_mode details summary tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, mb_old_iface, details) @@ -1482,6 +1570,7 @@ -- From now on, we just use the bits we need. cg_module = this_mod, cg_binds = core_binds, + cg_ccs = local_ccs, cg_tycons = tycons, cg_foreign = foreign_stubs0, cg_foreign_files = foreign_files, @@ -1491,6 +1580,7 @@ logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env tmpfs = hsc_tmpfs hsc_env + profile = targetProfile dflags data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -1498,20 +1588,20 @@ ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-} + (prepd_binds) <- {-# SCC "CorePrep" #-} corePrepPgm hsc_env this_mod location core_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds, denv, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} - withTiming logger dflags + withTiming logger (text "CoreToStg"<+>brackets (ppr this_mod)) (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ()) (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds) let cost_centre_info = - (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + (local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags prof_init | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info @@ -1523,7 +1613,7 @@ -- top-level function, so showPass isn't very useful here. -- Hence we have one showPass for the whole backend, the -- next showPass after this will be "Assembler". - withTiming logger dflags + withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ do cmms <- {-# SCC "StgToCmm" #-} @@ -1534,12 +1624,12 @@ ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger dflags cmms + Nothing -> cmmToRawCmm logger profile cmms Just h -> h dflags (Just this_mod) cmms let dump a = do unless (null a) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1577,7 +1667,7 @@ ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - (prepd_binds, _) <- {-# SCC "CorePrep" #-} + prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm hsc_env this_mod location core_binds data_tycons (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks) @@ -1596,6 +1686,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let profile = targetProfile dflags let hooks = hsc_hooks hsc_env let tmpfs = hsc_tmpfs hsc_env home_unit = hsc_home_unit hsc_env @@ -1606,12 +1697,12 @@ cmm_mod = mkHomeModule home_unit mod_name (cmm, ents) <- ioMsgMaybe $ do - (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) + (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename let msgs = warns `unionMessages` errs return (GhcPsMessage <$> msgs, cmm) liftIO $ do - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) + putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis. @@ -1623,12 +1714,12 @@ concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm unless (null cmmgroup) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform cmmgroup) rawCmms <- case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger dflags (Stream.yield cmmgroup) - Just h -> h dflags Nothing (Stream.yield cmmgroup) + Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) + Just h -> h dflags Nothing (Stream.yield cmmgroup) let foreign_stubs _ = let ip_init = ipInitCode dflags cmm_mod ents @@ -1682,7 +1773,7 @@ let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds - dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let stg_to_cmm = case stgToCmmHook hooks of Nothing -> StgToCmm.codeGen logger tmpfs @@ -1700,7 +1791,7 @@ let dump1 a = do unless (null a) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg + putDumpFileMaybe logger Opt_D_dump_cmm_from_stg "Cmm produced by codegen" FormatCMM (pdoc platform a) return a @@ -1717,7 +1808,7 @@ dump2 a = do unless (null a) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream) @@ -1821,7 +1912,7 @@ -- for linking, else we try to link 'main' and can't find it. -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc - hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + hval <- liftIO $ hscCompileCoreExpr hsc_env (src_span, Nothing) ds_expr return $ Just (ids, hval, fix_env) @@ -1893,7 +1984,7 @@ {- Prepare For Code Generation -} -- Do saturation and convert to A-normal form - (prepd_binds, _) <- {-# SCC "CorePrep" #-} + prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks) @@ -1910,10 +2001,10 @@ stg_binds data_tycons mod_breaks let src_span = srcLocSpan interactiveSrcLoc - liftIO $ loadDecls interp hsc_env src_span cbc + liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg) let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg @@ -1938,12 +2029,12 @@ -- | Load the given static-pointer table entries into the interpreter. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () -hscAddSptEntries hsc_env entries = do +hscAddSptEntries :: HscEnv -> Maybe ModuleNameWithIsBoot -> [SptEntry] -> IO () +hscAddSptEntries hsc_env mnwib entries = do let interp = hscInterp hsc_env let add_spt_entry :: SptEntry -> IO () add_spt_entry (SptEntry i fpr) = do - val <- loadName interp hsc_env (idName i) + val <- loadName interp hsc_env mnwib (idName i) addSptEntry interp fpr val mapM_ add_spt_entry entries @@ -2029,7 +2120,7 @@ hscParseThingWithLocation source linenumber parser str = do dflags <- getDynFlags logger <- getLogger - withTiming logger dflags + withTiming logger (text "Parser [source]") (const ()) $ {-# SCC "Parser" #-} do @@ -2041,9 +2132,9 @@ handleWarningsThrowErrors (getMessages pst) POk pst thing -> do logWarningsReportErrors (getMessages pst) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" FormatHaskell (ppr thing) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing) return thing @@ -2054,13 +2145,13 @@ %* * %********************************************************************* -} -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr hsc_env loc expr = case hscCompileCoreExprHook (hsc_hooks hsc_env) of Nothing -> hscCompileCoreExpr' hsc_env loc expr Just h -> h hsc_env loc expr -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr' :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr' hsc_env srcspan ds_expr = do { {- Simplify it -} -- Question: should we call SimpleOpt.simpleOptExpr here instead? @@ -2107,15 +2198,13 @@ dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do - eps <- hscEPS hsc_env - dumpIfSet logger dflags (dump_if_trace || dump_rn_stats) - "Interface statistics" - (ifaceStats eps) - where - dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env + let logger = hsc_logger hsc_env - dump_rn_stats = dopt Opt_D_dump_rn_stats dflags - dump_if_trace = dopt Opt_D_dump_if_trace dflags + dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats + dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace + when (dump_if_trace || dump_rn_stats) $ + logDumpMsg logger "Interface statistics" (ifaceStats eps) {- ********************************************************************** @@ -2130,3 +2219,8 @@ -- compute the length of x > 0 in base 10 len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + NoBackend == backend dflags 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 @@ -51,7 +51,9 @@ import GHC.Runtime.Context -import GHC.Driver.Config +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Diagnostic import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session @@ -75,7 +77,7 @@ import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Exception ( tryIO, AsyncException(..), evaluate ) +import GHC.Utils.Exception ( AsyncException(..), evaluate ) import GHC.Utils.Monad ( allM ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -83,6 +85,7 @@ import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger +import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants (isWindowsHost) @@ -100,7 +103,6 @@ import GHC.Unit import GHC.Unit.External -import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface @@ -132,7 +134,6 @@ import System.Directory import System.FilePath import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) @@ -206,13 +207,12 @@ depanalPartial excluded_mods allow_dup_roots = do hsc_env <- getSession let - dflags = hsc_dflags hsc_env targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env logger = hsc_logger hsc_env - withTiming logger dflags (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg logger dflags 2 (hcat [ + withTiming logger (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg logger 2 (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) @@ -274,6 +274,7 @@ where dflags = hsc_dflags hsc_env targets = map targetId (hsc_targets hsc_env) + diag_opts = initDiagOpts dflags is_known_module mod = any (is_my_target mod) targets @@ -305,7 +306,7 @@ missing = map (moduleName . ms_mod) $ filter (not . is_known_module) (mgModSummaries mod_graph) - warn = singleMessage $ mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan + warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags) -- | Describes which modules of the module graph need to be loaded. @@ -357,6 +358,7 @@ let dflags = hsc_dflags hsc_env state = hsc_units hsc_env pit = eps_PIT eps + diag_opts = initDiagOpts dflags let loadedPackages = map (unsafeLookupUnit state) @@ -371,7 +373,7 @@ = filter (\arg -> not $ any (matching state arg) loadedPackages) requestedArgs - let warn = singleMessage $ mkPlainMsgEnvelope dflags noSrcSpan (DriverUnusedPackages unusedArgs) + let warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs) when (not (null unusedArgs)) $ logDiagnostics (GhcDriverMessage <$> warn) @@ -435,7 +437,7 @@ checkMod m and_then | m `elementOfUniqSet` all_home_mods = and_then | otherwise = do - liftIO $ errorMsg logger dflags + liftIO $ errorMsg logger (text "no such module:" <+> quotes (ppr m)) return Failed @@ -454,16 +456,12 @@ -- are definitely unnecessary, then emit a warning. warnUnnecessarySourceImports mg2_with_srcimps - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - -- prune bits of the HPT which are definitely redundant now, - -- to save space. + let + -- prune the HPT so everything is not retained when doing an + -- upsweep. pruned_hpt = pruneHomePackageTable hpt1 (flattenSCCs mg2_with_srcimps) - stable_mods _ <- liftIO $ evaluate pruned_hpt @@ -472,19 +470,9 @@ -- write the pruned HPT to allow the old HPT to be GC'd. setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env - liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) + -- Unload everything + liftIO $ unload interp hsc_env - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- nonDetEltsUniqSet stable_obj ++ - nonDetEltsUniqSet stable_bco, - -- It's OK to use nonDetEltsUniqSet here - -- because it only affects linking. Besides - -- this list only serves as a poor man's set. - Just hmi <- [lookupHpt pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload interp hsc_env stable_linkables -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better @@ -500,11 +488,7 @@ -- nodes, and possibly just including the portion of the graph -- reachable from the module specified in the 2nd argument to load. -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode] - stable_mg :: [SCC ExtendedModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing + let partial_mg0, partial_mg:: [SCC ModuleGraphNode] maybe_top_mod = case how_much of LoadUpTo m -> Just m @@ -514,8 +498,7 @@ partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). + -- short of the specified module partial_mg | LoadDependenciesOf _mod <- how_much = assert (case last partial_mg0 of @@ -525,30 +508,10 @@ | otherwise = partial_mg0 - stable_mg = - [ AcyclicSCC ems - | AcyclicSCC (ModuleNode ems@(ExtendedModSummary ms _)) <- full_mg - , stable_mod_summary ms - ] - - stable_mod_summary ms = - ms_mod_name ms `elementOfUniqSet` stable_obj || - ms_mod_name ms `elementOfUniqSet` stable_bco - - -- the modules from partial_mg that are not also stable - -- NB. also keep cycles, we need to emit an error message later - unstable_mg = filter not_stable partial_mg - where not_stable (CyclicSCC _) = True - not_stable (AcyclicSCC (InstantiationNode _)) = True - not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ms _))) - = not $ stable_mod_summary ms - - -- Load all the stable modules first, before attempting to load - -- an unstable module (#7231). - mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg + mg = partial_mg - liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) + liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) n_jobs <- case parMakeCount dflags of Nothing -> liftIO getNumProcessors @@ -558,7 +521,7 @@ setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ - upsweep_fn mHscMessage pruned_hpt stable_mods mg + upsweep_fn mHscMessage pruned_hpt mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -574,7 +537,7 @@ then -- Easy; just relink it all. - do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.") + do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") -- Clean up after ourselves hsc_env1 <- getSession @@ -606,7 +569,7 @@ if ghcLink dflags == LinkBinary && isJust ofile && not do_linking then do - liftIO $ errorMsg logger dflags $ text + liftIO $ errorMsg logger $ text ("output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ @@ -620,7 +583,7 @@ -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.") + do liftIO $ debugTraceMsg logger 2 (text "Upsweep partially successful.") let modsDone_names = map (ms_mod . emsModSummary) modsDone @@ -690,7 +653,7 @@ loadFinish _all_ok Failed = do hsc_env <- getSession let interp = hscInterp hsc_env - liftIO $ unload interp hsc_env [] + liftIO $ unload interp hsc_env modifySession discardProg return Failed @@ -759,7 +722,7 @@ in case outputFile_ dflags of Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } } + Nothing -> hscSetFlags (dflags { outputFile_ = name_exe }) env -- ----------------------------------------------------------------------------- -- @@ -767,8 +730,7 @@ -- -- Before doing an upsweep, we can throw away: -- --- - For non-stable modules: --- - all ModDetails, all linked code +-- - all ModDetails, all linked code -- - all unlinked code that is out of date with respect to -- the source file -- @@ -778,16 +740,13 @@ -- compilation. pruneHomePackageTable :: HomePackageTable -> [ModSummary] - -> StableModules -> HomePackageTable -pruneHomePackageTable hpt summ (stable_obj, stable_bco) +pruneHomePackageTable hpt summ = mapHpt prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } + where prune hmi = hmi'{ hm_details = emptyModDetails } where modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + hmi' | mi_src_hash (hm_iface hmi) /= ms_hs_hash ms = hmi{ hm_linkable = Nothing } | otherwise = hmi @@ -795,9 +754,6 @@ ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - is_stable m = - m `elementOfUniqSet` stable_obj || - m `elementOfUniqSet` stable_bco -- ----------------------------------------------------------------------------- -- @@ -820,10 +776,10 @@ -- --------------------------------------------------------------------------- -- -- | Unloading -unload :: Interp -> HscEnv -> [Linkable] -> IO () -unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' +unload :: Interp -> HscEnv -> IO () +unload interp hsc_env = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload interp hsc_env stable_linkables + LinkInMemory -> Linker.unload interp hsc_env [] _other -> return () -- ----------------------------------------------------------------------------- @@ -836,7 +792,7 @@ modules near the bottom of the tree have not changed. - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the + for a module when we also load object code for all of the imports of the module. So we need to know that we will definitely not be recompiling any of these modules, and we can use the object code. @@ -849,11 +805,12 @@ stableObject m = all stableObject (imports m) && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) + && date(on-disk .o) >= date(on-disk .hi) + && hash(on-disk .hs) == hash recorded in .hi stableBCO m = all stable (imports m) - && date(BCO) > date(.hs) + && hash(on-disk .hs) == hash recorded alongside BCO @ These properties embody the following ideas: @@ -879,76 +836,11 @@ if the interface is out of date because an *external* interface has changed. The current code in GHC.Driver.Make handles this case fairly poorly, so be careful. --} -type StableModules = - ( UniqSet ModuleName -- stableObject - , UniqSet ModuleName -- stableBCO - ) + See also Note [When source is considered modified] +-} -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> UniqSet ModuleName -- all home modules - -> StableModules - -checkStability hpt sccs all_home_mods = - foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs - where - checkSCC :: StableModules -> SCC ModSummary -> StableModules - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco) - | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = - m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps - stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearest second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - -- - -- But see #5527, where someone ran into this and it caused - -- a problem. - - bco_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | otherwise = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - {- Parallel Upsweep - - The parallel upsweep attempts to concurrently compile the modules in the @@ -1006,13 +898,6 @@ data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot deriving (Eq, Ord) --- | Tests if an 'HscSource' is a boot file, primarily for constructing elements --- of 'BuildModule'. We conflate signatures and modules because they are bound --- in the same namespace; only boot interfaces can be disambiguated with --- `import {-# SOURCE #-}`. -hscSourceToIsBoot :: HscSource -> IsBootInterface -hscSourceToIsBoot HsBootFile = IsBoot -hscSourceToIsBoot _ = NotBoot mkBuildModule :: ModuleGraphNode -> BuildModule mkBuildModule = \case @@ -1045,11 +930,10 @@ -- ^ The number of workers we wish to run in parallel -> Maybe Messager -> HomePackageTable - -> StableModules -> [SCC ModuleGraphNode] -> m (SuccessFlag, [ModuleGraphNode]) -parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do +parUpsweep n_jobs mHscMessage old_hpt sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env @@ -1150,7 +1034,7 @@ , show mod_idx ] ] - -- Replace the default log_action with one that writes each + -- Replace the default logger with one that writes each -- message to the module's log_queue. The main thread will -- deal with synchronously printing these messages. let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger @@ -1163,18 +1047,21 @@ -- Unmask asynchronous exceptions and perform the thread-local -- work to compile the module (see parUpsweep_one). - m_res <- MC.try $ unmask $ prettyPrintGhcErrors dflags $ + m_res <- MC.try $ unmask $ prettyPrintGhcErrors logger $ case mod of InstantiationNode iuid -> do hsc_env <- readMVar hsc_env_var liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid pure Succeeded - ModuleNode ems -> - parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops - lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env) + ModuleNode ems -> do + let summary = emsModSummary ems + let lcl_dflags = ms_hspp_opts summary + let lcl_logger' = setLogFlags lcl_logger (initLogFlags lcl_dflags) + parUpsweep_one summary home_mod_map comp_graph_loops + lcl_logger' lcl_tmpfs dflags (hsc_home_unit hsc_env) mHscMessage par_sem hsc_env_var old_hpt_var - stable_mods mod_idx (length sccs) + mod_idx (length sccs) res <- case m_res of Right flag -> return flag @@ -1184,7 +1071,7 @@ -- interrupt, and the user doesn't have to be informed -- about that. when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_logger dflags (text (show exc))) + (errorMsg lcl_logger (text (show exc))) return Failed -- Populate the result MVar. @@ -1210,7 +1097,7 @@ -- Loop over each module in the compilation graph in order, printing -- each message from its log_queue. forM comp_graph $ \(mod,mvar,log_queue) -> do - printLogs logger dflags log_queue + printLogs logger log_queue result <- readMVar mvar if succeeded result then return (Just mod) else return Nothing @@ -1223,7 +1110,7 @@ -- of the upsweep. case cycle of Just mss -> do - liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss) + liftIO $ fatalErrorMsg logger (cyclicModuleErr mss) return (Failed,ok_results) Nothing -> do let success_flag = successIf (all isJust results) @@ -1242,10 +1129,9 @@ parLogAction log_queue _dflags !msgClass !srcSpan !msg = writeLogQueue log_queue (Just (msgClass,srcSpan,msg)) - -- Print each message from the log_queue using the log_action from the - -- session's DynFlags. - printLogs :: Logger -> DynFlags -> LogQueue -> IO () - printLogs !logger !dflags (LogQueue ref sem) = read_msgs + -- Print each message from the log_queue using the global logger + printLogs :: Logger -> LogQueue -> IO () + printLogs !logger (LogQueue ref sem) = read_msgs where read_msgs = do takeMVar sem msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) @@ -1254,7 +1140,7 @@ print_loop [] = read_msgs print_loop (x:xs) = case x of Just (msgClass,srcSpan,msg) -> do - putLogMsg logger dflags msgClass srcSpan msg + logMsg logger msgClass srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -1283,8 +1169,6 @@ -- ^ The MVar that synchronizes updates to the global HscEnv -> IORef HomePackageTable -- ^ The old HPT - -> StableModules - -- ^ Sets of stable objects and BCOs -> Int -- ^ The index of this module -> Int @@ -1292,7 +1176,7 @@ -> IO SuccessFlag -- ^ The result of this compile parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem - hsc_env_var old_hpt_var stable_mods mod_index num_mods = do + hsc_env_var old_hpt_var mod_index num_mods = do let this_build_mod = mkBuildModule0 mod @@ -1395,7 +1279,8 @@ hsc_env <- readMVar hsc_env_var old_hpt <- readIORef old_hpt_var - let logg err = printMessages lcl_logger lcl_dflags (srcErrorMessages err) + let lcl_diag_opts = initDiagOpts lcl_dflags + let logg err = printMessages lcl_logger lcl_diag_opts (srcErrorMessages err) -- Limit the number of parallel compiles. let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) @@ -1417,12 +1302,12 @@ -- EXCEPT the loop closer. However, our precomputed -- SCCs include the loop closer, so we have to filter -- it out. - Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ + Just loop -> typecheckLoop lcl_hsc_env' $ filter (/= moduleName (gwib_mod this_build_mod)) $ map (moduleName . gwib_mod) loop -- Compile the module. - mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt mod mod_index num_mods return (Just mod_info) @@ -1447,7 +1332,7 @@ -- closer! hsc_env'' <- case finish_loop of Nothing -> return hsc_env' - Just loop -> typecheckLoop lcl_dflags hsc_env' $ + Just loop -> typecheckLoop hsc_env' $ map (moduleName . gwib_mod) loop return (hsc_env'', localize_hsc_env hsc_env'') @@ -1476,7 +1361,6 @@ . GhcMonad m => Maybe Messager -> HomePackageTable -- ^ HPT from last time round (pruned) - -> StableModules -- ^ stable modules (see checkStability) -> [SCC ModuleGraphNode] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModuleGraphNode]) @@ -1486,7 +1370,7 @@ -- 2. The 'HscEnv' in the monad has an updated HPT -- 3. A list of modules which succeeded loading. -upsweep mHscMessage old_hpt stable_mods sccs = do +upsweep mHscMessage old_hpt sccs = do (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) return (res, reverse $ mgModSummaries' done) where @@ -1512,9 +1396,8 @@ nmods' = nmods - length dropped_ms when (not $ null dropped_ms) $ do - dflags <- getSessionDynFlags logger <- getLogger - liftIO $ debugTraceMsg logger dflags 2 (keepGoingPruneErr dropped_ms) + liftIO $ debugTraceMsg logger 2 (keepGoingPruneErr $ dropped_ms) (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' return (Failed, done') @@ -1533,7 +1416,7 @@ (CyclicSCC ms : mods) mod_index nmods = do dflags <- getSessionDynFlags logger <- getLogger - liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms) + liftIO $ fatalErrorMsg logger (cyclicModuleErr ms) if gopt Opt_KeepGoing dflags then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods else return (Failed, done) @@ -1575,7 +1458,7 @@ mb_mod_info <- handleSourceError (\err -> do logg mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods + mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt mod mod_index nmods logg mod Nothing -- log warnings return (Just mod_info) @@ -1618,7 +1501,7 @@ -- table. See Note [Grand plan for static forms] in -- GHC.Iface.Tidy.StaticPtrTable. when (backend (hsc_dflags hsc_env4) == Interpreter) $ - liftIO $ hscAddSptEntries hsc_env4 + liftIO $ hscAddSptEntries hsc_env4 (Just (ms_mnwib mod)) [ spt | Just linkable <- pure $ hm_linkable mod_info , unlinked <- linkableUnlinked linkable @@ -1628,15 +1511,6 @@ upsweep' old_hpt1 done' mods (mod_index+1) nmods -maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) -maybeGetIfaceDate dflags location - | writeInterfaceOnlyMode dflags - -- Minor optimization: it should be harmless to check the hi file location - -- always, but it's better to avoid hitting the filesystem if possible. - = modificationTimeIfExists (ml_hi_file location) - | otherwise - = return Nothing - upsweep_inst :: HscEnv -> Maybe Messager -> Int -- index of module @@ -1655,47 +1529,13 @@ upsweep_mod :: HscEnv -> Maybe Messager -> HomePackageTable - -> StableModules -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo -upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods +upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - mb_if_date = ms_iface_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary - - is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj - is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco - - old_hmi = lookupHpt old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - lcl_dflags = ms_hspp_opts summary - prevailing_backend = backend (hsc_dflags hsc_env) - local_backend = backend lcl_dflags - - -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fllvm to -fasm and vice-versa, or away from -fno-code, - -- otherwise we could end up trying to link object code to byte - -- code. - bcknd = case (prevailing_backend,local_backend) of - (LLVM,NCG) -> NCG - (NCG,LLVM) -> LLVM - (NoBackend,b) - | backendProducesObject b -> b - (Interpreter,b) - | backendProducesObject b -> b - _ -> prevailing_backend - - -- store the corrected backend into the summary - summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } } + old_hmi = lookupHpt old_hpt (ms_mod_name summary) -- The old interface is ok if -- a) we're compiling a source file, and the old HPT @@ -1715,104 +1555,13 @@ where iface = hm_iface hm_info - compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo - compile_it mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - mb_old_iface mb_linkable src_modified - - compile_it_discard_iface :: Maybe Linkable -> SourceModified - -> IO HomeModInfo - compile_it_discard_iface mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - Nothing mb_linkable src_modified - - -- With NoBackend we create empty linkables to avoid recompilation. - -- We have to detect these to recompile anyway if the backend changed - -- since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = + compileOne' Nothing mHscMessage hsc_env summary mod_index nmods + mb_old_iface mb_linkable in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) SourceUnmodifiedAndStable - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (backendProducesObject bcknd), is_stable_bco, - (bcknd /= NoBackend) `implies` not is_fake_linkable -> - assert (isJust old_hmi) $ -- must be in the old_hpt - let Just hmi = old_hmi in do - debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (backendProducesObject bcknd), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (bcknd /= NoBackend) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | backendProducesObject bcknd, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - _otherwise -> do - debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) SourceUnmodified - - -- See Note [Recompilation checking in -fno-code mode] - | writeInterfaceOnlyMode lcl_dflags, - Just if_date <- mb_if_date, - if_date >= hs_date -> do - debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name) - compile_it Nothing SourceUnmodified - - _otherwise -> do - debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing SourceModified + compile_it (old_hmi >>= hm_linkable) {- Note [-fno-code mode] @@ -1878,13 +1627,53 @@ generating temporary ones. -} --- Note [Recompilation checking in -fno-code mode] +-- Note [When source is considered modified] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we are compiling with -fno-code -fwrite-interface, there won't --- be any object code that we can compare against, nor should there --- be: we're *just* generating interface files. In this case, we --- want to check if the interface file is new, in lieu of the object --- file. See also #9243. +-- A number of functions in GHC.Driver accept a SourceModified argument, which +-- is part of how GHC determines whether recompilation may be avoided (see the +-- definition of the SourceModified data type for details). +-- +-- Determining whether or not a source file is considered modified depends not +-- only on the source file itself, but also on the output files which compiling +-- that module would produce. This is done because GHC supports a number of +-- flags which control which output files should be produced, e.g. -fno-code +-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the +-- source file has been modified since the last compile, but also whether the +-- source file has been modified since the last compile which produced all of +-- the output files which have been requested. +-- +-- Specifically, a source file is considered unmodified if it is up-to-date +-- relative to all of the output files which have been requested. Whether or +-- not an output file is up-to-date depends on what kind of file it is: +-- +-- * iface (.hi) files are considered up-to-date if (and only if) their +-- mi_src_hash field matches the hash of the source file, +-- +-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date +-- if (and only if) their modification times on the filesystem are greater +-- than or equal to the modification time of the corresponding .hi file. +-- +-- Why do we use '>=' rather than '>' for output files other than the .hi file? +-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a +-- resolution of 2 seconds), we may often find that the .hi and .o files have +-- the same modification time. Using >= is slightly unsafe, but it matches +-- make's behaviour. +-- +-- This strategy allows us to do the minimum work necessary in order to ensure +-- that all the files the user cares about are up-to-date; e.g. we should not +-- worry about .o files if the user has indicated that they are not interested +-- in them via -fno-code. See also #9243. +-- +-- Note that recompilation avoidance is dependent on .hi files being produced, +-- which does not happen if -fno-write-interface -fno-code is passed. That is, +-- passing -fno-write-interface -fno-code means that you cannot benefit from +-- recompilation avoidance. See also Note [-fno-code mode]. +-- +-- The correctness of this strategy depends on an assumption that whenever we +-- are producing multiple output files, the .hi file is always written first. +-- If this assumption is violated, we risk recompiling unnecessarily by +-- incorrectly regarding non-.hi files as outdated. +-- -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable @@ -1935,7 +1724,7 @@ let l = emsModSummary ems guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms pure l - = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) + = typecheckLoop hsc_env (map ms_mod_name non_boot) | otherwise = return hsc_env where @@ -1995,9 +1784,9 @@ -- NB: sometimes mods has duplicates; this is harmless because -- any duplicates get clobbered in addListToHpt and never get forced. -typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop dflags hsc_env mods = do - debugTraceMsg logger dflags 2 $ +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + debugTraceMsg logger 2 $ text "Re-typechecking loop: " <> ppr mods new_hpt <- fixIO $ \new_hpt -> do @@ -2188,17 +1977,17 @@ -- were necessary, then the edge would be part of a cycle. warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () warnUnnecessarySourceImports sccs = do - dflags <- getDynFlags - when (wopt Opt_WarnUnusedImports dflags) - (logDiagnostics (mkMessages $ listToBag (concatMap (check dflags . flattenSCC) sccs))) - where check dflags ms = + diag_opts <- initDiagOpts <$> getDynFlags + when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do + let check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn dflags i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] - warn :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage - warn dflags (L loc mod) = - GhcDriverMessage <$> mkPlainMsgEnvelope dflags loc (DriverUnnecessarySourceImports mod) + warn :: Located ModuleName -> MsgEnvelope GhcMessage + warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts + loc (DriverUnnecessarySourceImports mod) + logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs)) ----------------------------------------------------------------------------- @@ -2255,28 +2044,26 @@ dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - roots = hsc_targets hsc_env + roots = hsc_targets hsc_env old_summary_map :: ModNodeMap ExtendedModSummary old_summary_map = mkNodeMap old_summaries getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary) getRootSummary Target { targetId = TargetFile file mb_phase - , targetAllowObjCode = obj_allowed , targetContents = maybe_buf } = do exists <- liftIO $ doesFileExist file if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf + maybe_buf else return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file) getRootSummary Target { targetId = TargetModule modl - , targetAllowObjCode = obj_allowed , targetContents = maybe_buf } = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot - (L rootLoc modl) obj_allowed + (L rootLoc modl) maybe_buf excl_mods case maybe_summary of Nothing -> return $ Left $ moduleNotFoundErr modl @@ -2320,7 +2107,7 @@ } | otherwise = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True + is_boot wanted_mod Nothing excl_mods case mb_s of Nothing -> loop ss done @@ -2490,40 +2277,39 @@ -> [ExtendedModSummary] -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase - -> Bool -- object code allowed? -> Maybe (StringBuffer,UTCTime) -> IO (Either DriverMessages ExtendedModSummary) -summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf +summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. | Just old_summary <- findSummaryBySourceFile old_summaries src_fn = do let location = ms_location $ emsModSummary old_summary - dflags = hsc_dflags hsc_env - src_timestamp <- get_src_timestamp + src_hash <- get_src_hash -- The file exists; we checked in getRootSummary above. -- If it gets removed subsequently, then this - -- getModificationUTCTime may fail, but that's the right + -- getFileHash may fail, but that's the right -- behaviour. -- return the cached summary if the source didn't change - checkSummaryTimestamp - hsc_env dflags obj_allowed NotBoot (new_summary src_fn) - old_summary location src_timestamp + checkSummaryHash + hsc_env (new_summary src_fn) + old_summary location src_hash | otherwise - = do src_timestamp <- get_src_timestamp - new_summary src_fn src_timestamp + = do src_hash <- get_src_hash + new_summary src_fn src_hash where - get_src_timestamp = case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime src_fn - -- getModificationUTCTime may fail + -- src_fn does not necessarily exist on the filesystem, so we need to + -- check what kind of target we are dealing with + get_src_hash = case maybe_buf of + Just (buf,_) -> return $ fingerprintStringBuffer buf + Nothing -> liftIO $ getFileHash src_fn - new_summary src_fn src_timestamp = runExceptT $ do + new_summary src_fn src_hash = runExceptT $ do preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf @@ -2540,7 +2326,7 @@ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn - , nms_src_timestamp = src_timestamp + , nms_src_hash = src_hash , nms_is_boot = NotBoot , nms_hsc_src = if isHaskellSigFilename src_fn @@ -2548,7 +2334,6 @@ else HsSrcFile , nms_location = location , nms_mod = mod - , nms_obj_allowed = obj_allowed , nms_preimps = preimps } @@ -2564,23 +2349,19 @@ [] -> Nothing (x:_) -> Just x -checkSummaryTimestamp - :: HscEnv -> DynFlags -> Bool -> IsBootInterface - -> (UTCTime -> IO (Either e ExtendedModSummary)) - -> ExtendedModSummary -> ModLocation -> UTCTime +checkSummaryHash + :: HscEnv + -> (Fingerprint -> IO (Either e ExtendedModSummary)) + -> ExtendedModSummary -> ModLocation -> Fingerprint -> IO (Either e ExtendedModSummary) -checkSummaryTimestamp - hsc_env dflags obj_allowed is_boot new_summary +checkSummaryHash + hsc_env new_summary (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps}) - location src_timestamp - | ms_hs_date old_summary == src_timestamp && + location src_hash + | ms_hs_hash old_summary == src_hash && not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do -- update the object-file timestamp - obj_timestamp <- - if backendProducesObject (backend (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location is_boot - else return Nothing + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) -- We have to repopulate the Finder's cache for file targets -- because the file might not even be on the regular search path @@ -2593,7 +2374,7 @@ addHomeModuleToFinder fc home_unit (moduleName (ms_mod old_summary)) location - hi_timestamp <- maybeGetIfaceDate dflags location + hi_timestamp <- modificationTimeIfExists (ml_hi_file location) hie_timestamp <- modificationTimeIfExists (ml_hie_file location) return $ Right @@ -2608,7 +2389,7 @@ | otherwise = -- source changed: re-summarise. - new_summary src_timestamp + new_summary src_hash -- Summarise a module, and pick up source and timestamp. summariseModule @@ -2617,13 +2398,12 @@ -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods + maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing @@ -2635,19 +2415,17 @@ let location = ms_location $ emsModSummary old_summary src_fn = expectJust "summariseModule" (ml_hs_file location) - -- check the modification time on the source file, and + -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the -- file has disappeared, we need to call the Finder again. case maybe_buf of - Just (_,t) -> - Just <$> check_timestamp old_summary location src_fn t + Just (buf,_) -> + Just <$> check_hash old_summary location src_fn (fingerprintStringBuffer buf) Nothing -> do - m <- tryIO (getModificationUTCTime src_fn) - case m of - Right t -> - Just <$> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e + mb_hash <- fileHashIfExists src_fn + case mb_hash of + Just hash -> Just <$> check_hash old_summary location src_fn hash + Nothing -> find_it | otherwise = find_it where @@ -2656,9 +2434,9 @@ fc = hsc_FC hsc_env units = hsc_units hsc_env - check_timestamp old_summary location src_fn = - checkSummaryTimestamp - hsc_env dflags obj_allowed is_boot + check_hash old_summary location src_fn = + checkSummaryHash + hsc_env (new_summary location (ms_mod $ emsModSummary old_summary) src_fn) old_summary location @@ -2685,12 +2463,12 @@ -- Check that it exists -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of + maybe_h <- fileHashIfExists src_fn + case maybe_h of Nothing -> return $ Left $ noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t + Just h -> new_summary location' mod src_fn h - new_summary location mod src_fn src_timestamp + new_summary location mod src_fn src_hash = runExceptT $ do preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf @@ -2718,12 +2496,11 @@ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn - , nms_src_timestamp = src_timestamp + , nms_src_hash = src_hash , nms_is_boot = is_boot , nms_hsc_src = hsc_src , nms_location = location , nms_mod = mod - , nms_obj_allowed = obj_allowed , nms_preimps = preimps } @@ -2732,12 +2509,11 @@ data MakeNewModSummary = MakeNewModSummary { nms_src_fn :: FilePath - , nms_src_timestamp :: UTCTime + , nms_src_hash :: Fingerprint , nms_is_boot :: IsBootInterface , nms_hsc_src :: HscSource , nms_location :: ModLocation , nms_mod :: Module - , nms_obj_allowed :: Bool , nms_preimps :: PreprocessedImports } @@ -2745,16 +2521,9 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps let dflags = hsc_dflags hsc_env - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- liftIO $ - if backendProducesObject (backend dflags) - || nms_obj_allowed -- bug #1205 - then getObjTimestamp nms_location nms_is_boot - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags nms_location + obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) + dyn_obj_timestamp <- modificationTimeIfExists (dynamicOutputFile dflags (ml_obj_file nms_location)) + hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name @@ -2775,20 +2544,15 @@ pi_theimps ++ extra_sig_imports ++ ((,) Nothing . noLoc <$> implicit_sigs) - , ms_hs_date = nms_src_timestamp + , ms_hs_hash = nms_src_hash , ms_iface_date = hi_timestamp , ms_hie_date = hie_timestamp , ms_obj_date = obj_timestamp + , ms_dyn_obj_date = dyn_obj_timestamp } , emsInstantiatedUnits = inst_deps } -getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime) -getObjTimestamp location is_boot - = case is_boot of - IsBoot -> return Nothing - NotBoot -> modificationTimeIfExists (ml_obj_file location) - data PreprocessedImports = PreprocessedImports { pi_local_dflags :: DynFlags @@ -2840,7 +2604,7 @@ logger <- getLogger let deferDiagnostics _dflags !msgClass !srcSpan !msg = do - let action = putLogMsg logger dflags msgClass srcSpan msg + let action = logMsg logger msgClass srcSpan msg case msgClass of MCDiagnostic SevWarning _reason -> atomicModifyIORef' warnings $ \i -> (action: i, ()) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -96,7 +96,7 @@ let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted - liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted) + liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted) -- Process them one by one, dumping results into makefile -- and complaining about cycles @@ -105,10 +105,10 @@ mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles logger dflags module_graph + liftIO $ dumpModCycles logger module_graph -- Tidy up - liftIO $ endMkDependHS logger dflags files + liftIO $ endMkDependHS logger files -- Unconditional exiting is a bad idea. If an error occurs we'll get an --exception; if that is not caught it's fine, but at least we have a @@ -347,9 +347,9 @@ -- ----------------------------------------------------------------- -endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO () +endMkDependHS :: Logger -> MkDepFiles -> IO () -endMkDependHS logger dflags +endMkDependHS logger (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) = do @@ -367,11 +367,11 @@ -- Create a backup of the original makefile when (isJust makefile_hdl) $ do - showPass logger dflags ("Backing up " ++ makefile) + showPass logger ("Backing up " ++ makefile) SysTools.copyFile makefile (makefile++".bak") -- Copy the new makefile in place - showPass logger dflags "Installing new makefile" + showPass logger "Installing new makefile" SysTools.copyFile tmp_file makefile @@ -379,16 +379,16 @@ -- Module cycles ----------------------------------------------------------------- -dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO () -dumpModCycles logger dflags module_graph - | not (dopt Opt_D_dump_mod_cycles dflags) +dumpModCycles :: Logger -> ModuleGraph -> IO () +dumpModCycles logger module_graph + | not (logHasDumpFlag logger Opt_D_dump_mod_cycles) = return () | null cycles - = putMsg logger dflags (text "No module cycles") + = putMsg logger (text "No module cycles") | otherwise - = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles) + = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles) where topoSort = filterToposortToModules $ GHC.topSortModuleGraph True module_graph Nothing 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 @@ -42,13 +42,15 @@ import GHC.Platform import GHC.Tc.Types +import GHC.Tc.Utils.Monad hiding ( getImports ) import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Diagnostic import GHC.Driver.Phases import GHC.Driver.Session import GHC.Driver.Backend @@ -74,7 +76,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Monad import GHC.Utils.Exception as Exception import GHC.Utils.Logger @@ -89,6 +90,7 @@ import GHC.Iface.Make ( mkFullIface ) import GHC.Runtime.Loader ( initializePlugins ) + import GHC.Types.Basic ( SuccessFlag(..) ) import GHC.Types.Error ( singleMessage, getMessages ) import GHC.Types.Name.Env @@ -99,7 +101,6 @@ import GHC.Unit import GHC.Unit.Env -import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface @@ -118,7 +119,7 @@ import Data.Version import Data.Either ( partitionEithers ) -import Data.Time ( UTCTime ) +import Data.Time ( getCurrentTime ) -- --------------------------------------------------------------------------- -- Pre-process @@ -165,8 +166,12 @@ (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs)) Just msgs' -> msgs' - to_driver_message (GhcDriverMessage msg) = Just msg - to_driver_message _other = Nothing + to_driver_message = \case + GhcDriverMessage msg + -> Just msg + GhcPsMessage (PsHeaderMessage msg) + -> Just (DriverPsHeaderMessage (PsHeaderMessage msg)) + _ -> Nothing -- --------------------------------------------------------------------------- @@ -188,7 +193,6 @@ -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne = compileOne' Nothing (Just batchMsg) @@ -201,15 +205,13 @@ -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne' m_tc_result mHscMessage hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable - source_modified0 = do - debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) + debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) let flags = hsc_dflags hsc_env0 in do unless (gopt Opt_KeepHiFiles flags) $ @@ -219,8 +221,7 @@ addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] - plugin_hsc_env <- initializePlugins hsc_env - + plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary)) let runPostTc = compileOnePostTc plugin_hsc_env summary case m_tc_result of @@ -229,27 +230,27 @@ runPostTc (FrontendTypecheck tc_result) emptyMessages Nothing _ -> do status <- hscRecompStatus mHscMessage plugin_hsc_env summary - source_modified mb_old_iface (mod_index, nmods) + mb_old_iface mb_old_linkable (mod_index, nmods) case status of - HscUpToDate iface -> do - massert ( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) + HscUpToDate iface old_linkable -> do + massert ( isJust old_linkable || isNoLink (ghcLink dflags) ) -- See Note [ModDetails and --make mode] details <- initModDetails plugin_hsc_env summary iface - return $! HomeModInfo iface details mb_old_linkable + return $! HomeModInfo iface details old_linkable HscRecompNeeded mb_old_hash -> do (tc_result, warnings) <- hscTypecheckAndGetWarnings plugin_hsc_env summary runPostTc tc_result warnings mb_old_hash - where dflags0 = ms_hspp_opts summary + where lcl_dflags = ms_hspp_opts summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary mod_graph = hsc_mod_graph hsc_env0 needsLinker = needsTemplateHaskellOrQQ mod_graph - isDynWay = any (== WayDyn) (ways dflags0) - isProfWay = any (== WayProf) (ways dflags0) - internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) + isDynWay = any (== WayDyn) (ways lcl_dflags) + isProfWay = any (== WayProf) (ways lcl_dflags) + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) logger = hsc_logger hsc_env0 tmpfs = hsc_tmpfs hsc_env0 @@ -259,8 +260,8 @@ -- when using -fexternal-interpreter. dflags1 = if hostIsDynamic && internalInterpreter && not isDynWay && not isProfWay && needsLinker - then gopt_set dflags0 Opt_BuildDynamicToo - else dflags0 + then gopt_set lcl_dflags Opt_BuildDynamicToo + else lcl_dflags -- #16331 - when no "internal interpreter" is available but we -- need to process some TemplateHaskell or QuasiQuotes, we automatically @@ -288,20 +289,11 @@ -- was set), force it to generate byte-code. This is NOT transitive and -- only applies to direct targets. | loadAsByteCode - = (Interpreter, dflags2 { backend = Interpreter }) + = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp) | otherwise = (backend dflags, dflags2) dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } - hsc_env = hsc_env0 {hsc_dflags = dflags} - - -- -fforce-recomp should also work with --make - force_recomp = gopt Opt_ForceRecomp dflags - source_modified - -- #8042: Usually pre-compiled code is preferred to be loaded in ghci - -- if available. So, if the "*" prefix was used, force recompilation - -- to make sure byte-code is loaded. - | force_recomp || loadAsByteCode = SourceModified - | otherwise = source_modified0 + hsc_env = hscSetFlags dflags hsc_env0 always_do_basic_recompilation_check = case bcknd of Interpreter -> True @@ -532,15 +524,15 @@ -- the linkables to link linkables = map (expectJust "link".hm_linkable) home_mod_infos - debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) -- check for the -no-link flag if isNoLink (ghcLink dflags) - then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).") + then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).") return Succeeded else do - let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) obj_files = concatMap getOfiles linkables platform = targetPlatform dflags exe_file = exeFileName platform staticLink (outputFile dflags) @@ -548,11 +540,11 @@ linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.") + then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do - compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...") + compilationProgressMsg logger (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -562,13 +554,13 @@ other -> panicBadLink other link dflags unit_env obj_files pkg_deps - debugTraceMsg logger dflags 3 (text "link: done") + debugTraceMsg logger 3 (text "link: done") -- linkBinary only returns if it succeeds return Succeeded | otherwise - = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$ text " Main.main not exported; not linking.") return Succeeded @@ -702,13 +694,11 @@ mb_basename output maybe_loc foreign_os = do let - dflags0 = hsc_dflags hsc_env0 - -- Decide where dump files should go based on the pipeline output - dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } - hsc_env = hsc_env0 {hsc_dflags = dflags} - logger = hsc_logger hsc_env - tmpfs = hsc_tmpfs hsc_env + hsc_env = hscUpdateFlags (\dflags -> dflags { dumpPrefix = Just (basename ++ ".")}) hsc_env0 + logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + dflags = hsc_dflags hsc_env (input_basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . @@ -768,11 +758,10 @@ return fn (_, _) -> return input_fn - debugTraceMsg logger dflags 4 (text "Running the pipeline") + debugTraceMsg logger 4 (text "Running the pipeline") r <- runPipeline' start_phase hsc_env env input_fn' maybe_loc foreign_os - let dflags = hsc_dflags hsc_env when isHaskellishFile $ dynamicTooState dflags >>= \case DT_Dont -> return () @@ -798,7 +787,7 @@ -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) | OSMinGW32 <- platformOS (targetPlatform dflags) -> return () | otherwise -> do - debugTraceMsg logger dflags 4 + debugTraceMsg logger 4 (text "Running the full pipeline again for -dynamic-too") let dflags0 = flip gopt_unset Opt_BuildDynamicToo $ setDynamicNow @@ -812,10 +801,8 @@ , ue_units = unit_state , ue_unit_dbs = Just dbs } - let hsc_env'' = hsc_env' - { hsc_dflags = dflags1 - , hsc_unit_env = unit_env - } + let hsc_env'' = hscSetFlags dflags1 + $ hsc_env' { hsc_unit_env = unit_env } _ <- runPipeline' start_phase hsc_env'' env input_fn' maybe_loc foreign_os return () @@ -872,7 +859,7 @@ when (final_fn /= input_fn) $ do let msg = "Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'" line_prag = "{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n" - liftIO $ showPass logger dflags msg + liftIO $ showPass logger msg liftIO $ copyWithHeader line_prag input_fn final_fn return final_fn @@ -886,7 +873,7 @@ " but I wanted to stop at phase " ++ show stopPhase) _ - -> do liftIO $ debugTraceMsg logger dflags 4 + -> do liftIO $ debugTraceMsg logger 4 (text "Running phase" <+> ppr phase) case phase of @@ -1148,17 +1135,19 @@ runPhase (RealPhase (Cpp sf)) input_fn = do dflags0 <- getDynFlags - logger <- getLogger - src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + let parser_opts0 = initParserOpts dflags0 + src_opts <- liftIO $ getOptionsFromFile parser_opts0 input_fn (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 liftIO $ checkProcessArgsResult unhandled_flags + if not (xopt LangExt.Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (gopt Opt_Pp dflags1) $ - liftIO $ handleFlagWarnings logger dflags1 warns + unless (gopt Opt_Pp dflags1) $ do + logger <- getLogger + liftIO $ handleFlagWarnings logger (initDiagOpts dflags1) warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. @@ -1166,6 +1155,7 @@ else do output_fn <- phaseOutputFilename (HsPp sf) hsc_env <- getPipeSession + logger <- getLogger liftIO $ doCpp logger (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) @@ -1174,16 +1164,16 @@ input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + src_opts <- liftIO $ getOptionsFromFile parser_opts0 output_fn (dflags2, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags2 liftIO $ checkProcessArgsResult unhandled_flags - unless (gopt Opt_Pp dflags2) $ - liftIO $ handleFlagWarnings logger dflags2 warns + unless (gopt Opt_Pp dflags2) $ do + logger <- getLogger + liftIO $ handleFlagWarnings logger (initDiagOpts dflags2) warns -- the HsPp pass below will emit warnings - setDynFlags dflags2 - return (RealPhase (HsPp sf), output_fn) ------------------------------------------------------------------------------- @@ -1208,12 +1198,13 @@ ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- liftIO $ getOptionsFromFile dflags output_fn + let parser_opts = initParserOpts dflags + src_opts <- liftIO $ getOptionsFromFile parser_opts output_fn (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ handleFlagWarnings logger dflags1 warns + liftIO $ handleFlagWarnings logger (initDiagOpts dflags1) warns return (RealPhase (Hsc sf), output_fn) @@ -1225,9 +1216,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn = do -- normal Hsc mode, not mkdependHS dflags0 <- getDynFlags - - PipeEnv{ stop_phase=stop, - src_basename=basename, + PipeEnv{ src_basename=basename, src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which @@ -1257,48 +1246,16 @@ -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above location <- getLocation src_flavour mod_name - dt_state <- dynamicTooState dflags let o_file = ml_obj_file location -- The real object file - -- dynamic-too *also* produces the dyn_o_file, so have to check - -- that's there, and if it's not, regenerate both .o and - -- .dyn_o - dyn_o_file = case dt_state of - DT_OK - | not (writeInterfaceOnlyMode dflags) - -> Just (dynamicOutputFile dflags o_file) - _ -> Nothing hi_file = ml_hi_file location hie_file = ml_hie_file location - dest_file | writeInterfaceOnlyMode dflags - = hi_file - | otherwise - = o_file - - -- Figure out if the source has changed, for recompilation avoidance. - -- - -- Setting source_unchanged to True means that M.o, M.dyn_o (or M.hie) seems - -- to be up to date wrt M.hs; so no need to recompile unless imports have - -- changed (which the compiler itself figures out). - -- Setting source_unchanged to False tells the compiler that M.o or M.dyn_o is out of - -- date wrt M.hs (or M.o/dyn_o doesn't exist) so we must recompile regardless. - src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) + dyn_o_file = dynamicOutputFile dflags o_file - source_unchanged <- liftIO $ - if not (isStopLn stop) - -- SourceModified unconditionally if - -- (a) recompilation checker is off, or - -- (b) we aren't going all the way to .o file (e.g. ghc -S) - then return SourceModified - -- Otherwise look at file modification dates - else do dest_file_mod <- sourceModified dest_file src_timestamp - dyn_file_mod <- traverse (flip sourceModified src_timestamp) dyn_o_file - hie_file_mod <- if gopt Opt_WriteHie dflags - then sourceModified hie_file - src_timestamp - else pure False - if dest_file_mod || hie_file_mod || fromMaybe False dyn_file_mod - then return SourceModified - else return SourceUnmodified + src_hash <- liftIO $ getFileHash (basename <.> suff) + hi_date <- liftIO $ modificationTimeIfExists hi_file + hie_date <- liftIO $ modificationTimeIfExists hie_file + o_mod <- liftIO $ modificationTimeIfExists o_file + dyn_o_mod <- liftIO $ modificationTimeIfExists dyn_o_file PipeState{hsc_env=hsc_env'} <- getPipeState @@ -1316,17 +1273,19 @@ ms_hspp_opts = dflags, ms_hspp_buf = hspp_buf, ms_location = location, - ms_hs_date = src_timestamp, - ms_obj_date = Nothing, + ms_hs_hash = src_hash, + ms_obj_date = o_mod, + ms_dyn_obj_date = dyn_o_mod, ms_parsed_mod = Nothing, - ms_iface_date = Nothing, - ms_hie_date = Nothing, + ms_iface_date = hi_date, + ms_hie_date = hie_date, ms_textual_imps = imps, ms_srcimps = src_imps } + -- run the compiler! - let msg hsc_env _ what _ = oneShotMsg hsc_env what - plugin_hsc_env' <- liftIO $ initializePlugins hsc_env' + let msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what + plugin_hsc_env' <- liftIO $ initializePlugins hsc_env' (Just $ ms_mnwib mod_summary) -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. @@ -1335,11 +1294,11 @@ let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } status <- liftIO $ hscRecompStatus (Just msg) plugin_hsc_env mod_summary - source_unchanged Nothing (1, 1) + Nothing Nothing (1, 1) logger <- getLogger case status of - HscUpToDate iface -> + HscUpToDate iface _ -> do liftIO $ touchObjectFile logger dflags o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't get Nothing) @@ -1369,14 +1328,9 @@ next_phase <- case hscBackendAction of HscUpdate iface -> do setIface iface - -- Need to set a fake linkable - let setLinkableAndStop = do - unless (isHsBootOrSig $ ms_hsc_src mod_summary) $ - setLinkable (LM (ms_hs_date mod_summary) (ms_mod mod_summary) []) - return $ RealPhase StopLn case backend dflags of - NoBackend -> setLinkableAndStop - Interpreter -> setLinkableAndStop + NoBackend -> return $ RealPhase StopLn + Interpreter -> return $ RealPhase StopLn _ -> return hscBackendPhase -- Need to create .o, and handle -dynamic-too _ -> return hscBackendPhase @@ -1437,7 +1391,7 @@ return [DotO stub_o] let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time = ms_hs_date mod_summary + unlinked_time <- liftIO getCurrentTime -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in -- the case where the local clock is out of sync @@ -1643,10 +1597,10 @@ runPhase (RealPhase (As with_cpp)) input_fn = do hsc_env <- getPipeSession - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let unit_env = hsc_unit_env hsc_env - let platform = ue_platform unit_env + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let unit_env = hsc_unit_env hsc_env + let platform = ue_platform unit_env -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) @@ -1710,7 +1664,7 @@ , GHC.SysTools.FileOption "" temp_outputFilename ]) - liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler") + liftIO $ debugTraceMsg logger 4 (text "Running the assembler") runAssembler input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1835,9 +1789,10 @@ runPhase (RealPhase LlvmMangle) input_fn = do let next_phase = As False output_fn <- phaseOutputFilename next_phase - dflags <- getDynFlags + platform <- (ue_platform . hsc_unit_env) <$> getPipeSession logger <- getLogger - liftIO $ llvmFixupAsm logger dflags input_fn output_fn + liftIO $ withTiming logger (text "LLVM Mangler") id $ + llvmFixupAsm platform input_fn output_fn return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- @@ -1917,7 +1872,7 @@ linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - putLogMsg logger dflags MCInfo noSrcSpan + logMsg logger MCInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -1929,7 +1884,7 @@ -- | Run CPP -- --- UnitState is needed to compute MIN_VERSION macros +-- UnitEnv is needed to compute MIN_VERSION macros doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags @@ -2163,22 +2118,6 @@ -- ----------------------------------------------------------------------------- -- Misc. -writeInterfaceOnlyMode :: DynFlags -> Bool -writeInterfaceOnlyMode dflags = - gopt Opt_WriteInterface dflags && - NoBackend == backend dflags - --- | Figure out if a source file was modified after an output file (or if we --- anyways need to consider the source file modified since the output is gone). -sourceModified :: FilePath -- ^ destination file we are looking for - -> UTCTime -- ^ last time of modification of source file - -> IO Bool -- ^ do we need to regenerate the output? -sourceModified dest_file src_timestamp = do - dest_file_exists <- doesFileExist dest_file - if not dest_file_exists - then return True -- Need to recompile - else do t2 <- getModificationUTCTime dest_file - return (t2 <= src_timestamp) -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -0,0 +1,204 @@ +-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. +-- +-- Note that this does /not/ currently support the use case of annotating +-- every subexpression in an 'HsExpr' with its 'Type'. For more information on +-- this task, see #12706, #15320, #16804, and #17331. +module GHC.Hs.Syn.Type ( + -- * Extracting types from HsExpr + lhsExprType, hsExprType, + -- * Extracting types from HsSyn + hsLitType, hsPatType, hsLPatType + + ) where + +import GHC.Prelude + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Hs +import GHC.Tc.Types.Evidence +import GHC.Types.Id +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- +************************************************************************ +* * + Extracting the type from HsSyn +* * +************************************************************************ + +-} + +hsLPatType :: LPat GhcTc -> Type +hsLPatType (L _ p) = hsPatType p + +hsPatType :: Pat GhcTc -> Type +hsPatType (ParPat _ _ pat _) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat _ lvar) = idType (unLoc lvar) +hsPatType (BangPat _ pat) = hsLPatType pat +hsPatType (LazyPat _ pat) = hsLPatType pat +hsPatType (LitPat _ lit) = hsLitType lit +hsPatType (AsPat _ var _) = idType (unLoc var) +hsPatType (ViewPat ty _ _) = ty +hsPatType (ListPat ty _) = mkListTy ty +hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make +hsPatType (SumPat tys _ _ _ ) = mkSumTy tys +hsPatType (ConPat { pat_con = lcon + , pat_con_ext = ConPatTc + { cpt_arg_tys = tys + } + }) + = conLikeResTy (unLoc lcon) tys +hsPatType (SigPat ty _ _) = ty +hsPatType (NPat ty _ _ _) = ty +hsPatType (NPlusKPat ty _ _ _ _ _) = ty +hsPatType (XPat ext) = + case ext of + CoPat _ _ ty -> ty + ExpansionPat _ pat -> hsPatType pat +hsPatType (SplicePat v _) = dataConCantHappen v + +hsLitType :: HsLit (GhcPass p) -> Type +hsLitType (HsChar _ _) = charTy +hsLitType (HsCharPrim _ _) = charPrimTy +hsLitType (HsString _ _) = stringTy +hsLitType (HsStringPrim _ _) = addrPrimTy +hsLitType (HsInt _ _) = intTy +hsLitType (HsIntPrim _ _) = intPrimTy +hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord64Prim _ _) = word64PrimTy +hsLitType (HsInteger _ _ ty) = ty +hsLitType (HsRat _ _ ty) = ty +hsLitType (HsFloatPrim _ _) = floatPrimTy +hsLitType (HsDoublePrim _ _) = doublePrimTy + + +-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion. +lhsExprType :: LHsExpr GhcTc -> Type +lhsExprType (L _ e) = hsExprType e + +-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. +hsExprType :: HsExpr GhcTc -> Type +hsExprType (HsVar _ (L _ id)) = idType id +hsExprType (HsUnboundVar (HER _ ty _) _) = ty +hsExprType (HsRecSel _ (FieldOcc id _)) = idType id +hsExprType (HsOverLabel v _) = dataConCantHappen v +hsExprType (HsIPVar v _) = dataConCantHappen v +hsExprType (HsOverLit _ lit) = overLitType lit +hsExprType (HsLit _ lit) = hsLitType lit +hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group +hsExprType (HsLamCase _ (MG { mg_ext = match_group })) = matchGroupTcType match_group +hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f +hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x +hsExprType (OpApp v _ _ _) = dataConCantHappen v +hsExprType (NegApp _ _ se) = syntaxExprType se +hsExprType (HsPar _ _ e _) = lhsExprType e +hsExprType (SectionL v _ _) = dataConCantHappen v +hsExprType (SectionR v _ _) = dataConCantHappen v +hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args +hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys +hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group +hsExprType (HsIf _ _ t _) = lhsExprType t +hsExprType (HsMultiIf ty _) = ty +hsExprType (HsLet _ _ body) = lhsExprType body +hsExprType (HsDo ty _ _) = ty +hsExprType (ExplicitList ty _) = mkListTy ty +hsExprType (RecordCon con_expr _ _) = hsExprType con_expr +hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) = + case cons of + con_like:_ -> conLikeResTy con_like out_tys + [] -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons" + (ppr e) +hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v +hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v +hsExprType (ExprWithTySig _ e _) = lhsExprType e +hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of + Just op -> piResultTy (syntaxExprType op) asi_ty + Nothing -> asi_ty + where + asi_ty = arithSeqInfoType asi +hsExprType (HsBracket v _) = dataConCantHappen v +hsExprType (HsRnBracketOut v _ _) = dataConCantHappen v +hsExprType (HsTcBracketOut ty _wrap _bracket _pending) = ty +hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE" + (ppr e) + -- Typed splices should have been eliminated during zonking, but we + -- can't use `dataConCantHappen` since they are still present before + -- than in the typechecked AST. +hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top +hsExprType (HsStatic _ e) = lhsExprType e +hsExprType (HsTick _ _ e) = lhsExprType e +hsExprType (HsBinTick _ _ _ e) = lhsExprType e +hsExprType (HsPragE _ _ e) = lhsExprType e +hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e +hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e +hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con + +arithSeqInfoType :: ArithSeqInfo GhcTc -> Type +arithSeqInfoType asi = mkListTy $ case asi of + From x -> lhsExprType x + FromThen x _ -> lhsExprType x + FromTo x _ -> lhsExprType x + FromThenTo x _ _ -> lhsExprType x + +conLikeType :: ConLike -> Type +conLikeType (RealDataCon con) = dataConNonlinearType con +conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of + Just (_, ty, _) -> ty + Nothing -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position" + (ppr patsyn) + +hsTupArgType :: HsTupArg GhcTc -> Type +hsTupArgType (Present _ e) = lhsExprType e +hsTupArgType (Missing (Scaled _ ty)) = ty + + +-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas)) +type PRType = (Type, [Type]) + +prTypeType :: PRType -> Type +prTypeType (ty, tys) + | null tys = ty + | otherwise = piResultTys ty (reverse tys) + +liftPRType :: (Type -> Type) -> PRType -> PRType +liftPRType f pty = (f (prTypeType pty), []) + +hsWrapperType :: HsWrapper -> Type -> Type +hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) + where + go WpHole = id + go (w1 `WpCompose` w2) = go w1 . go w2 + go (WpFun _ w2 (Scaled m exp_arg) _) = liftPRType $ \t -> + let act_res = funResultTy t + exp_res = hsWrapperType w2 act_res + in mkFunctionType m exp_arg exp_res + go (WpCast co) = liftPRType $ \_ -> coercionRKind co + go (WpEvLam v) = liftPRType $ mkInvisFunTyMany (idType v) + go (WpEvApp _) = liftPRType $ funResultTy + go (WpTyLam tv) = liftPRType $ mkForAllTy tv Inferred + go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) + go (WpLet _) = id + go (WpMultCoercion _) = id + +lhsCmdTopType :: LHsCmdTop GhcTc -> Type +lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty + +matchGroupTcType :: MatchGroupTc -> Type +matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res + +syntaxExprType :: SyntaxExpr GhcTc -> Type +syntaxExprType (SyntaxExprTc e _ _) = hsExprType e +syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc" diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -45,13 +45,13 @@ import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make -import GHC.Core.Ppr import GHC.Core.Coercion import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) +import GHC.Core.Ppr import GHC.Builtin.Names import GHC.Builtin.Types.Prim @@ -138,7 +138,7 @@ = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env - ; withTiming logger dflags + ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ do { -- Desugar the program @@ -189,7 +189,7 @@ = simpleOptPgm simpl_opts mod final_pgm rules_for_imps -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" + ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps @@ -203,8 +203,9 @@ ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names - dep_files merged pluginModules + + ; usages <- mkUsageInfo hsc_env mod hsc_src (imp_mods imports) used_names + dep_files merged -- id_mod /= mod when we are processing an hsig, but hsigs -- never desugared and compiled (there's no code!) -- Consequently, this should hold for any ModGuts that make @@ -286,10 +287,9 @@ deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - showPass logger dflags "Desugar" + showPass logger "Desugar" -- Do desugaring (tc_msgs, mb_result) <- runTcInteractive hsc_env $ @@ -304,7 +304,7 @@ case mb_core_expr of Nothing -> return () - Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared" + Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared" FormatCore (pprCoreExpr expr) -- callers (i.e. ioMsgMaybe) expect that no expression is returned if @@ -430,7 +430,7 @@ -- and take the body apart into a (f args) form ; dflags <- getDynFlags ; case decomposeRuleLhs dflags bndrs'' lhs'' of { - Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; + Left msg -> do { diagnosticDs msg; return Nothing } ; Right (final_bndrs, fn_id, args) -> do { let is_local = isLocalId fn_id @@ -465,26 +465,10 @@ | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries , idInlineActivation lhs_id `competesWith` rule_act - = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) - + = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id - = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , whenPprDebug (ppr bad_rule) ]) - + = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id) | otherwise = return () @@ -661,9 +645,9 @@ (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2) It looks like we can write this in Haskell directly, but we can't: -the levity polymorphism checks defeat us. Note that `x` is a levity- -polymorphic variable. So we must wire it in with a compulsory -unfolding, like other levity-polymorphic primops. +the reprsentation polymorphism checks defeat us. Note that `x` is a +representation-polymorphic variable. So we must wire it in with a +compulsory unfolding, like other representation-polymorphic primops. The challenge is that UnsafeEquality is a GADT, and wiring in a GADT is *hard*: it has a worker separate from its wrapper, with all manner diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -20,7 +20,7 @@ import GHC.HsToCore.Monad import GHC.Hs -import GHC.Tc.Utils.Zonk +import GHC.Hs.Syn.Type -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -33,6 +33,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type( splitPiTy ) import GHC.Core.Multiplicity +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Types.Evidence import GHC.Core import GHC.Core.FVs @@ -40,6 +41,7 @@ import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) + import GHC.Types.Id import GHC.Core.ConLike import GHC.Builtin.Types @@ -121,8 +123,7 @@ -> Maybe Id -> DsM () check_lev_poly _ Nothing = return () check_lev_poly arity (Just id) - = dsNoLevPoly (nTimes arity res_type (idType id)) - (text "In the result of the function" <+> quotes (ppr id)) + = dsNoLevPoly (nTimes arity res_type (idType id)) (LevityCheckMkCmdEnv id) -- arr :: forall b c. (b -> c) -> a b c @@ -631,8 +632,7 @@ (L loc stmts)) env_ids = do putSrcSpanDsA loc $ - dsNoLevPoly stmts_ty - (text "In the do-command:" <+> ppr do_block) + dsNoLevPoly stmts_ty (LevityCheckDoCmd do_block) (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -702,8 +702,7 @@ DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty - (text "When desugaring the command:" <+> ppr cmd) + = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty (LevityCheckDesugaringCmd cmd) ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } -- Feed back the list of local variables actually used a command, @@ -792,8 +791,7 @@ -- ---> premap (\ (xs) -> ((xs), ())) c dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do - putSrcSpanDsA loc $ dsNoLevPoly res_ty - (text "In the command:" <+> ppr body) + putSrcSpanDsA loc $ dsNoLevPoly res_ty (LevityCheckInCmd body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids env_var <- newSysLocalDs Many env_ty @@ -861,7 +859,7 @@ out_ty = mkBigCoreVarTupTy out_ids before_c_ty = mkCorePairTy in_ty1 out_ty after_c_ty = mkCorePairTy c_ty out_ty - dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here + dsNoLevPoly c_ty LevityCheckCmdStmt snd_fn <- mkSndExpr c_ty out_ty return (do_premap ids in_ty before_c_ty out_ty core_mux $ do_compose ids before_c_ty after_c_ty out_ty @@ -1104,7 +1102,7 @@ dsfixCmdStmts ids local_vars out_ids stmts = trimInput (dsCmdStmts ids local_vars out_ids stmts) - -- TODO: Add levity polymorphism check for the resulting expression. + -- TODO: Add representation polymorphism check for the resulting expression. -- But I (Richard E.) don't know enough about arrows to do so. dsCmdStmts diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -24,10 +24,17 @@ import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Config +import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Module + import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) import GHC.HsToCore.Monad +import GHC.HsToCore.Errors.Types import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) @@ -41,41 +48,41 @@ import GHC.Core.Opt.Arity ( etaExpand ) import GHC.Core.Unfold.Make import GHC.Core.FVs -import GHC.Data.Graph.Directed import GHC.Core.Predicate - -import GHC.Builtin.Names import GHC.Core.TyCon -import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity +import GHC.Core.Rules + +import GHC.Builtin.Names import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) + +import GHC.Tc.Types.Evidence + import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Set -import GHC.Core.Rules import GHC.Types.Var.Env import GHC.Types.Var( EvVar ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) -import GHC.Unit.Module import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) + import GHC.Data.Maybe import GHC.Data.OrdList +import GHC.Data.Graph.Directed import GHC.Data.Bag -import GHC.Types.Basic -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Data.FastString + +import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc -import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import GHC.Utils.Monad -import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Trace + import Control.Monad {-********************************************************************** @@ -90,8 +97,8 @@ dsTopLHsBinds binds -- see Note [Strict binds checks] | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) - = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict bindings") bang_binds + = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds + ; mapBagM_ (top_level_err StrictBinds) bang_binds ; return nilOL } | otherwise @@ -107,10 +114,9 @@ unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds bang_binds = filterBag (isBangedHsBind . unLoc) binds - top_level_err desc (L loc bind) + top_level_err bindsType (L loc bind) = putSrcSpanDs (locA loc) $ - errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") - 2 (ppr bind)) + diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind) -- | Desugar all other kind of bindings, Ids of strict binds are returned to @@ -226,6 +232,9 @@ -- A very important common case: one exported variable -- Non-recursive bindings come through this way -- So do self-recursive bindings + -- gbl_id = wrap (/\tvs \dicts. let ev_binds + -- letrec bind_prs + -- in lcl_id) | [export] <- exports , ABE { abe_poly = global_id, abe_mono = local_id , abe_wrap = wrap, abe_prags = prags } <- export @@ -259,26 +268,28 @@ -- Another common case: no tyvars, no dicts -- In this case we can have a much simpler desugaring + -- lcl_id{inl-prag} = rhs -- Auxiliary binds + -- gbl_id = lcl_id |> co -- Main binds | null tyvars, null dicts - - = do { let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local - , abe_prags = prags }) - = do { core_wrap <- dsHsWrapper wrap - ; return (makeCorePair dflags global - (isDefaultMethod prags) - 0 (core_wrap (Var local))) } - ; main_binds <- mapM mk_bind exports + = do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr) + mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id + , abe_wrap = wrap }) + -- No SpecPrags (no dicts) + -- Can't be a default method (default methods are singletons) + = do { core_wrap <- dsHsWrapper wrap + ; return ( gbl_id `setInlinePragma` defaultInlinePragma + , core_wrap (Var lcl_id)) } - ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } + ; main_prs <- mapM mk_main exports + ; return (force_vars, flattenBinds ds_ev_binds + ++ mk_aux_binds bind_prs ++ main_prs ) } -- The general case -- See Note [Desugaring AbsBinds] | otherwise - = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs - | (lcl_id, rhs) <- bind_prs ] + = do { let aux_binds = Rec (mk_aux_binds bind_prs) -- Monomorphic recursion possible, hence Rec + new_force_vars = get_new_force_vars force_vars locals = map abe_mono exports all_locals = locals ++ new_force_vars @@ -286,7 +297,7 @@ tup_ty = exprType tup_expr ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ mkCoreLets ds_ev_binds $ - mkLet core_bind $ + mkLet aux_binds $ tup_expr ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs) @@ -320,19 +331,21 @@ , (poly_tup_id, poly_tup_rhs) : concat export_binds_s) } where + mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)] + mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs + | (lcl_id, rhs) <- bind_prs + , let lcl_w_inline = lookupVarEnv inline_env lcl_id + `orElse` lcl_id ] + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with - -- the inline pragma from the source - -- The type checker put the inline pragma - -- on the *global* Id, so we need to transfer it + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports , let prag = idInlinePragma gbl_id ] - add_inline :: Id -> Id -- tran - add_inline lcl_id = lookupVarEnv inline_env lcl_id - `orElse` lcl_id - global_env :: IdEnv Id -- Maps local Id to its global exported Id global_env = mkVarEnv [ (local, global) @@ -616,8 +629,8 @@ There are several checks around properly formed strict bindings. They all link to this Note. These checks must be here in the desugarer because we cannot know whether or not a type is unlifted until after zonking, due -to levity polymorphism. These checks all used to be handled in the typechecker -in checkStrictBinds (before Jan '17). +to representation polymorphism. These checks all used to be handled in the +typechecker in checkStrictBinds (before Jan '17). We define an "unlifted bind" to be any bind that binds an unlifted id. Note that @@ -665,16 +678,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ - do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for class method selector" - <+> quotes (ppr poly_id)) + do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id) ; return Nothing } -- There is no point in trying to specialise a class op -- Moreover, classops don't (currently) have an inl_sat arity set -- (it would be Just 0) and that in turn makes makeCorePair bleat | no_act_spec && isNeverActive rule_act = putSrcSpanDs loc $ - do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" - <+> quotes (ppr poly_id)) + do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id) ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that -- See Note [Activation pragmas for SPECIALISE] @@ -699,7 +710,7 @@ -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ dflags <- getDynFlags ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { - Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; + Left msg -> do { diagnosticDs msg; return Nothing } ; Right (rule_bndrs, _fn, rule_lhs_args) -> do { this_mod <- getModule @@ -768,12 +779,9 @@ dsMkUserRule this_mod is_local name act fn bndrs args rhs = do let rule = mkRule this_mod False is_local name act fn bndrs args rhs when (isOrphan (ru_orphan rule)) $ - diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule) + diagnosticDs (DsOrphanRule rule) return rule -ruleOrphWarn :: CoreRule -> SDoc -ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule - {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to warn that using SPECIALISE for a function marked INLINE @@ -836,7 +844,7 @@ -} decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr - -> Either SDoc ([Var], Id, [CoreExpr]) + -> Either DsMessage ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs -- may add some extra dictionary binders (see Note [Free dictionaries]) @@ -846,10 +854,10 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs | not (null unbound) -- Check for things unbound on LHS -- See Note [Unused spec binders] - = Left (vcat (map dead_msg unbound)) + = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) | Var funId <- fun2 , Just con <- isDataConId_maybe funId - = Left (constructor_msg con) -- See Note [No RULES on datacons] + = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] | Just (fn_id, args) <- decompose fun2 args2 , let extra_bndrs = mk_extra_bndrs fn_id args = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs @@ -861,7 +869,7 @@ Right (orig_bndrs ++ extra_bndrs, fn_id, args) | otherwise - = Left bad_shape_msg + = Left (DsRuleLhsTooComplicated orig_lhs lhs2) where simpl_opts = initSimpleOpts dflags lhs1 = drop_dicts orig_lhs @@ -893,24 +901,6 @@ decompose _ _ = Nothing - bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") - 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 - , text "Orig lhs:" <+> ppr orig_lhs]) - dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr - , text "is not bound in RULE lhs"]) - 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs - , text "Orig lhs:" <+> ppr orig_lhs - , text "optimised lhs:" <+> ppr lhs2 ]) - pp_bndr bndr - | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) - | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr)) - | otherwise = text "variable" <+> quotes (ppr bndr) - - constructor_msg con = vcat - [ text "A constructor," <+> ppr con <> - text ", appears as outermost match in RULE lhs." - , text "This rule will be ignored." ] - drop_dicts :: CoreExpr -> CoreExpr drop_dicts e = wrap_lets needed bnds body @@ -1135,7 +1125,7 @@ ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a arg = w1 (Var x) - ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc + ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg (LevityCheckWpFun doc) ; if ok then return (\e -> (Lam x (w2 (app e arg)))) else return id } -- this return is irrelevant @@ -1145,7 +1135,7 @@ ; return (\e -> App e core_tm) } -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ - errDs (text "Multiplicity coercions are currently not supported") + diagnosticDs DsMultiplicityCoercionsNotSupported ; return $ \e -> e } -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -124,7 +124,7 @@ modBreaks <- mkModBreaks hsc_env mod tickCount entries let logger = hsc_logger hsc_env - dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell + putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) return (binds1, HpcInfo tickCount hashNo, modBreaks) diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -250,7 +250,7 @@ gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString gadtConArgDocs con_args res_ty = case con_args of PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] - RecConGADT _ -> con_arg_docs 1 [res_ty] + RecConGADT _ _ -> con_arg_docs 1 [res_ty] con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -29,6 +29,7 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) +import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env @@ -57,7 +58,6 @@ import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.TyCo.Ppr( pprWithTYPE ) import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic @@ -71,7 +71,6 @@ import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad -import Data.Void( absurd ) {- ************************************************************************ @@ -125,7 +124,7 @@ = putSrcSpanDs (locA loc) $ -- see Note [Strict binds checks] in GHC.HsToCore.Binds if is_polymorphic bind - then errDsCoreExpr (poly_bind_err bind) + then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind) -- data Ptr a = Ptr Addr# -- f x = let p@(Ptr y) = ... in ... -- Here the binding for 'p' is polymorphic, but does @@ -133,7 +132,7 @@ -- use a bang pattern. #6078. else do { when (looksLazyPatBind bind) $ - warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + diagnosticDs (DsUnbangedStrictPatterns bind) -- Complain about a binding that looks lazy -- e.g. let I# y = x in ... -- Remember, in checkStrictBinds we are going to do strict @@ -148,22 +147,11 @@ = not (null tvs && null evs) is_polymorphic _ = False - unlifted_must_be_bang bind - = hang (text "Pattern bindings containing unlifted types should use" $$ - text "an outermost bang pattern:") - 2 (ppr bind) - poly_bind_err bind - = hang (text "You can't mix polymorphic and unlifted bindings:") - 2 (ppr bind) $$ - text "Probable fix: add a type signature" - ds_val_bind (is_rec, binds) _body | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds = assert (isRec is_rec ) - errDsCoreExpr $ - hang (text "Recursive bindings for unlifted types aren't allowed:") - 2 (vcat (map ppr (bagToList binds))) + errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds) -- Ordinary case for bindings; none should be unlifted ds_val_bind (is_rec, binds) body @@ -252,16 +240,16 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e --- | Variant of 'dsLExpr' that ensures that the result is not levity --- polymorphic. This should be used when the resulting expression will --- be an argument to some other function. --- See Note [Levity polymorphism checking] in "GHC.HsToCore.Monad" --- See Note [Levity polymorphism invariants] in "GHC.Core" +-- | Variant of 'dsLExpr' that ensures that the result is not +-- representation- polymorphic. This should be used when the resulting +-- expression will be an argument to some other function. +-- See Note [Representation polymorphism checking] in "GHC.HsToCore.Monad" +-- See Note [Representation polymorphism invariants] in "GHC.Core" dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e) = putSrcSpanDsA loc $ do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; dsNoLevPolyExpr e' (LevityCheckHsExpr e) ; return e' } dsExpr :: HsExpr GhcTc -> DsM CoreExpr @@ -273,10 +261,10 @@ dsExpr (HsPar _ _ e _) = dsLExpr e dsExpr (ExprWithTySig _ e _) = dsLExpr e -dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" +dsExpr (HsIPVar x _) = dataConCantHappen x -dsExpr (HsGetField x _ _) = absurd x -dsExpr (HsProjection x _) = absurd x +dsExpr (HsGetField x _ _) = dataConCantHappen x +dsExpr (HsProjection x _) = dataConCantHappen x dsExpr (HsLit _ lit) = do { warnAboutOverflowedLit lit @@ -747,7 +735,7 @@ -- Template Haskell stuff -dsExpr (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" +dsExpr (HsRnBracketOut x _ _) = dataConCantHappen x dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) @@ -777,13 +765,12 @@ -- HsSyn constructs that just shouldn't be here, because -- the renamer removed them. See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs] -dsExpr (HsOverLabel x _) = absurd x -dsExpr (OpApp x _ _ _) = absurd x -dsExpr (SectionL x _ _) = absurd x -dsExpr (SectionR x _ _) = absurd x - +dsExpr (HsOverLabel x _) = dataConCantHappen x +dsExpr (OpApp x _ _ _) = dataConCantHappen x +dsExpr (SectionL x _ _) = dataConCantHappen x +dsExpr (SectionR x _ _) = dataConCantHappen x +dsExpr (HsBracket x _) = dataConCantHappen x -- HsSyn constructs that just shouldn't be here: -dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" dsExpr (HsDo {}) = panic "dsExpr:HsDo" ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr @@ -809,10 +796,12 @@ ; core_arg_wraps <- mapM dsHsWrapper arg_wraps ; core_res_wrap <- dsHsWrapper res_wrap ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) - (\_ -> core_res_wrap (mkApps fun wrapped_args)) } + ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ]) + (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) } + -- Use mkCoreApps instead of mkApps: + -- unboxed types are possible with RebindableSyntax (#19883) where - mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) + mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] @@ -1069,7 +1058,7 @@ = do { ds_con <- dsHsConLike con ; ids <- newSysLocalsDs tys -- newSysLocalDs: /can/ be lev-poly; see - -- Note [Checking levity-polymorphic data constructors] + -- Note [Checking representation-polymorphic data constructors] ; return (mkLams tvs $ mkLams ids $ ds_con `mkTyApps` mkTyVarTys tvs @@ -1101,8 +1090,7 @@ -- Warn about discarding non-() things in 'monadic' binding ; if warn_unused && not (isUnitTy norm_elt_ty) - then diagnosticDs (WarningWithFlag Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) + then diagnosticDs (DsUnusedDoBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, @@ -1111,39 +1099,30 @@ case tcSplitAppTy_maybe norm_elt_ty of Just (elt_m_ty, _) | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> diagnosticDs (WarningWithFlag Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) + -> diagnosticDs (DsWrongDoBind rhs elt_ty) _ -> return () } } | otherwise -- RHS does have type of form (m ty), which is weird = return () -- but at least this warning is irrelevant -badMonadBind :: LHsExpr GhcTc -> Type -> SDoc -badMonadBind rhs elt_ty - = vcat [ hang (text "A do-notation statement discarded a result of type") - 2 (quotes (ppr elt_ty)) - , hang (text "Suppress this warning by saying") - 2 (quotes $ text "_ <-" <+> ppr rhs) - ] - {- ************************************************************************ * * - Levity polymorphism checks + Representation polymorphism checks * * ************************************************************************ -Note [Checking for levity-polymorphic functions] +Note [Checking for representation-polymorphic functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot have levity polymorphic function arguments. See -Note [Levity polymorphism invariants] in GHC.Core. That is +We cannot have representation-polymorphic function arguments. See +Note [Representation polymorphism invariants] in GHC.Core. That is checked by dsLExprNoLP. But what about const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b) Since `unsafeCoerce#` has no binding, it has a compulsory unfolding. -But that compulsory unfolding is a levity-polymorphic lambda, which +But that compulsory unfolding is a representation-polymorphic lambda, which is no good. So we want to reject this. On the other hand const True (unsafeCoerce# @LiftedRep @UnliftedRep) is absolutely fine. @@ -1153,7 +1132,7 @@ wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021 triggers this case. -Note that if `f :: forall r (a :: Type r). blah`, then +Note that if `f :: forall r (a :: TYPE r). blah`, then const True f is absolutely fine. Here `f` is a function, represented by a pointer, and we can pass it to `const` (or anything else). (See @@ -1163,13 +1142,14 @@ Interestingly, this approach does not look to see whether the Id in question will be eta expanded. The logic is this: * Either the Id in question is saturated or not. - * If it is, then it surely can't have levity polymorphic arguments. - If its wrapped type contains levity polymorphic arguments, reject. - * If it's not, then it can't be eta expanded with levity polymorphic - argument. If its wrapped type contains levity polymorphic arguments, reject. + * If it is, then it surely can't have representation-polymorphic arguments. + If its wrapped type contains representation-polymorphic arguments, reject. + * If it's not, then it can't be eta expanded with representation-polymorphic + argument. If its wrapped type contains representation-polymorphic arguments, + reject. So, either way, we're good to reject. -Note [Nasty wrinkle in levity-polymorphic function check] +Note [Nasty wrinkle in representation-polymorphic function check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A nasty wrinkle came up in T13244 type family Rep x @@ -1186,7 +1166,7 @@ If we look only at final type of the expression, namely: Unboxed Int -> Int, the kind of the argument type is TYPE (Rep Int), and that needs -type-family reduction to say whether it is lifted or unlifted. +type-family reduction to determine the runtime representation. So we split the wrapper into the instantiating part (which is what we really want) and everything else; see splitWrapper. This is @@ -1201,12 +1181,12 @@ quux = obscure (#,#) Around the (#,#) we'll get some type /abstractions/ wrapping some type -/instantiations/. In the levity-poly error message we really only want -to report the instantiations. Hence passing (mkHsWrap w_inner e) to -checkLevPolyArgs. +/instantiations/. In the representation polymorphism error message, +we really only want to report the instantiations. +Hence passing (mkHsWrap w_inner e) to checkLevPolyArgs. -Note [Checking levity-polymorphic data constructors] +Note [Checking representation-polymorphic data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly, generated by a newtype data constructor, we might get this: (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4 @@ -1214,12 +1194,14 @@ which we want to accept. See Note [Typechecking data constructors] in GHC.Tc.Gen.Head. -Because we want to accept this, we switch off Lint's levity-poly checks -when Lint checks the output of the desugarer; see the lf_check_levity_poly -flag in GHC.Core.Lint.lintCoreBindings. +Because we want to accept this, we switch off Lint's +representation polymorphism checks when Lint checks the output of the +desugarer; see the lf_check_levity_poly flag in +GHC.Core.Lint.lintCoreBindings. -We can get this situation both for levity-polymorphic newtype constructors -(T18481), and for levity-polymorphic algebraic data types, e.g (T18481a) +We can get this situation both for representation-polymorphic +newtype constructors (T18481), and for representation-polymorphic +algebraic data types, e.g (T18481a) type T :: TYPE (BoxedRep r) -> TYPE (BoxedRep r) data T a = MkT Int @@ -1231,7 +1213,7 @@ dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr -- Looks for a function 'f' wrapped in type applications (HsAppType) -- or wrappers (HsWrap), and checks that any hasNoBinding function --- is not levity polymorphic, *after* instantiation with those wrappers +-- is not representation-polymorphic, *after* instantiation with those wrappers dsHsWrapped orig_hs_expr = go idHsWrapper orig_hs_expr where @@ -1278,7 +1260,7 @@ -- Split a wrapper w into (outer_wrap <.> inner_wrap), where -- inner_wrap does instantiation (type and evidence application) -- and outer_wrap is everything else, such as a final cast --- See Note [Nasty wrinkle in levity-polymorphic function check] +-- See Note [Nasty wrinkle in representation-polymorphic function check] splitWrapper wrap = go WpHole wrap where @@ -1322,9 +1304,7 @@ ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) } | otherwise - = errDsCoreExpr $ hang (text "Invalid instantiation of" <+> - quotes (ppr withDictName) <+> text "at type:") - 4 (ppr wrapped_ty) + = errDsCoreExpr (DsInvalidInstantiationDictAtType wrapped_ty) {- Note [withDict] ~~~~~~~~~~~~~~~~~~ @@ -1391,7 +1371,7 @@ Some further observations about `withDict`: * Every use of `withDict` must be instantiated at a /particular/ class C. - It's a bit like levity polymorphism: we don't allow class-polymorphic + It's a bit like representation polymorphism: we don't allow class-polymorphic calls of `withDict`. We check this in the desugarer -- and then we can immediately replace this invocation of `withDict` with appropriate class-specific Core code. @@ -1403,8 +1383,8 @@ * For examples of how `withDict` is used in the `base` library, see `withSNat` in GHC.TypeNats, as well as `withSChar` and `withSSymbol` n GHC.TypeLits. -* The `r` is levity polymorphic to support things like `withTypeable` in - `Data.Typeable.Internal`. +* The `r` is representation-polymorphic, + to support things like `withTypeable` in `Data.Typeable.Internal`. * As an alternative to `withDict`, one could define functions like `withT` above in terms of `unsafeCoerce`. This is more error-prone, however. @@ -1456,8 +1436,8 @@ -- | Takes a (pretty-printed) expression, a function, and its -- instantiated type. If the function is a hasNoBinding op, and the --- type has levity-polymorphic arguments, issue an error. --- Note [Checking for levity-polymorphic functions] +-- type has representation-polymorphic arguments, issue an error. +-- Note [Checking for representation-polymorphic functions] checkLevPolyFunction :: Outputable e => e -> Id -> Type -> DsM () checkLevPolyFunction orig_hs_expr var ty | hasNoBinding var @@ -1466,30 +1446,17 @@ = return () checkLevPolyArgs :: Outputable e => e -> Type -> DsM () --- Check that there are no levity-polymorphic arguments in +-- Check that there are no representation-polymorphic arguments in -- the supplied type -- E.g. Given (forall a. t1 -> t2 -> blah), ensure that t1,t2 --- are not levity-polymorhic +-- are not representation-polymorhic -- -- Pass orig_hs_expr, so that the user can see entire thing --- Note [Checking for levity-polymorphic functions] +-- Note [Checking for representation-polymorphic functions] checkLevPolyArgs orig_hs_expr ty | let (binders, _) = splitPiTys ty arg_tys = mapMaybe binderRelevantType_maybe binders bad_tys = filter isTypeLevPoly arg_tys , not (null bad_tys) - = errDs $ vcat - [ hang (text "Cannot use function with levity-polymorphic arguments:") - 2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty)) - , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat - [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" - , text "are eta-expanded internally because they must occur fully saturated." - , text "Use -fprint-typechecker-elaboration to display the full expression.)" - ] - , hang (text "Levity-polymorphic arguments:") - 2 $ vcat $ map - (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) - bad_tys - ] - + = diagnosticDs $ DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys | otherwise = return () diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -88,7 +88,7 @@ dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) - -- Precondition: none have levity-polymorphic types + -- Precondition: none have representation-polymorphic types -> Safety -- Safety of the call -> Type -- Type of the result: IO t -> DsM CoreExpr -- Result, of type ??? @@ -127,7 +127,7 @@ ty = mkInfForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty -unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic +unboxArg :: CoreExpr -- The supplied argument, not representation-polymorphic -> DsM (CoreExpr, -- To pass as the actual argument CoreExpr -> CoreExpr -- Wrapper to unbox the arg ) @@ -135,7 +135,7 @@ -- (x#::Int#, \W. case x of I# x# -> W) -- where W is a CoreExpr that probably mentions x# --- always returns a non-levity-polymorphic expression +-- always returns a non-representation-polymorphic expression unboxArg arg -- Primitive types: nothing to unbox diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -218,7 +218,7 @@ (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty (arg_tys, io_res_ty) = tcSplitFunTys rho - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) let @@ -323,7 +323,7 @@ (tvs, fun_ty) = tcSplitForAllInvisTyVars ty (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism ccall_uniq <- newUnique dflags <- getDynFlags diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -49,7 +49,8 @@ dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr dsGuarded grhss rhs_ty rhss_nablas = do match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas - error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty + error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty + (text "pattern binding") extractMatchResult match_result error_expr -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -16,7 +16,8 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import GHC.Hs -import GHC.Tc.Utils.Zonk +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) +import GHC.Hs.Syn.Type import GHC.Core import GHC.Core.Make @@ -138,8 +139,7 @@ , Var unzip_fn' , inner_list_expr' ] - dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) - (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) + dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) (LevityCheckInFunUse using) -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold lists rather than single values @@ -278,8 +278,8 @@ let res_ty = exprType core_list2 h_ty = u1_ty `mkVisFunTyMany` res_ty - -- no levity polymorphism here, as list comprehensions don't work - -- with RebindableSyntax. NB: These are *not* monad comps. + -- no representation polymorphism here, as list comprehensions + -- don't work with RebindableSyntax. NB: These are *not* monad comps. [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty] -- the "fail" value ... @@ -647,7 +647,7 @@ mkMcUnzipM :: TransForm -> HsExpr GhcTc -- fmap -> Id -- Of type n (a,b,c) - -> [Type] -- [a,b,c] (not levity-polymorphic) + -> [Type] -- [a,b,c] (not representation-polymorphic) -> DsM CoreExpr -- Of type (n a, n b, n c) mkMcUnzipM ThenForm _ ys _ = return (Var ys) -- No unzipping to do diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -1,7 +1,9 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -23,13 +25,13 @@ import GHC.Prelude import GHC.Platform -import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) +import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs -import GHC.Tc.Utils.Zonk +import GHC.Hs.Syn.Type import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc @@ -46,6 +48,7 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal import GHC.Core.Type @@ -231,7 +234,6 @@ PgBang -> matchBangs vars ty (dropGroup eqns) PgCo {} -> matchCoercion vars ty (dropGroup eqns) PgView {} -> matchView vars ty (dropGroup eqns) - PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) where eqns' = NEL.toList eqns ne l = case NEL.nonEmpty l of Just nel -> nel @@ -247,10 +249,9 @@ case p of PgView e _ -> e:acc _ -> acc) [] group) eqns maybeWarn [] = return () - maybeWarn l = diagnosticDs WarningWithoutFlag (vcat l) + maybeWarn l = diagnosticDs (DsAggregatedViewExpressions l) in - maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) - (filter (not . null) gs)) + maybeWarn $ filter (not . null) gs matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) -- See Note [Empty case expressions] @@ -289,47 +290,43 @@ = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 + let TcViewPat viewExpr pat = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getViewPat <$> eqns -- compile the view expressions - ; viewExpr' <- dsLExpr viewExpr + ; viewExpr' <- dsExpr viewExpr ; return (mkViewMatchResult var' (mkCoreAppDs (text "matchView") viewExpr' (Var var)) match_result) } -matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) --- Since overloaded list patterns are treated as view patterns, --- the code is roughly the same as for matchView - = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 - ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty) -- we construct the overall type by hand - ; match_result <- match (var':vars) ty $ NEL.toList $ - decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern - ; e' <- dsSyntaxExpr e [Var var] - ; return (mkViewMatchResult var' e' match_result) - } - -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc +getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc getCoPat (XPat (CoPat _ pat _)) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat _ pat ) = unLoc pat getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ _ pat) = unLoc pat +getViewPat (TcViewPat _ pat) = pat getViewPat _ = panic "getViewPat" -getOLPat (ListPat (ListPatTc ty (Just _)) pats) - = ListPat (ListPatTc ty Nothing) pats -getOLPat _ = panic "getOLPat" +-- | Use this pattern synonym to match on a 'ViewPat'. +-- +-- N.B.: View patterns can occur inside HsExpansions. +pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc +pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat)) + +getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc) +getTcViewPat (ViewPat _ viewLExpr pat) = (unLoc viewLExpr, unLoc pat) +getTcViewPat (XPat (ExpansionPat _ p)) = getTcViewPat p +getTcViewPat p = pprPanic "getTcViewPat" (ppr p) + {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -455,16 +452,13 @@ = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) ; unless (null unlifted_bndrs) $ putSrcSpanDs (getLocA pat) $ - errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ - text "Unlifted variables:") - 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) - unlifted_bndrs))) + diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats ) +tidy1 _ _ (ListPat ty pats) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) @@ -910,7 +904,6 @@ | PgView (LHsExpr GhcTc) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) - | PgOverloadedList {- Note [Don't use Literal for PgN] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1176,11 +1169,11 @@ case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (XPat (CoPat _ p _)) = PgCo (hsPatType p) - -- Type of innelexp pattern patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit) +patGroup platform (XPat ext) = case ext of + CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern + ExpansionPat _ p -> patGroup platform p patGroup _ pat = pprPanic "patGroup" (ppr pat) {- diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -30,6 +30,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr ) +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Monad import GHC.HsToCore.Utils @@ -56,7 +57,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString -import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) import Control.Monad @@ -263,10 +263,7 @@ , idName conv_fn `elem` conversionNames , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = diagnosticDs (WarningWithFlag Opt_WarnIdentities) - (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ text "can probably be omitted" - ]) + = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv) warnAboutIdentities _ _ _ = return () conversionNames :: [Name] @@ -347,37 +344,13 @@ checkPositive :: Integer -> Name -> DsM () checkPositive i tc = when (i < 0) $ - diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is negative but" <+> ppr tc - <+> text "only supports positive numbers" - ]) + diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags)) check i tc minB maxB = when (i < minB || i > maxB) $ - diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> text "range" - <+> integer minB <> text ".." <> integer maxB - , sug ]) + diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags)) where - sug | minB == -i -- Note [Suggest NegativeLiterals] - , i > 0 - , not (xopt LangExt.NegativeLiterals dflags) - = text "If you are trying to write a large negative literal, use NegativeLiterals" - | otherwise = Outputable.empty - -{- -Note [Suggest NegativeLiterals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you write - x :: Int8 - x = -128 -it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. -We get an erroneous suggestion for - x = 128 -but perhaps that does not matter too much. --} + bounds = Just (MinBound minB, MaxBound maxB) warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) @@ -441,7 +414,7 @@ | otherwise = return () where raiseWarning = - diagnosticDs (WarningWithFlag Opt_WarnEmptyEnumerations) (text "Enumeration is empty") + diagnosticDs DsEmptyEnumeration getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -40,7 +40,7 @@ dsGetCompleteMatches, -- Warnings and errors - DsWarning, diagnosticDs, warnIfSetDs, errDs, errDsCoreExpr, + DsWarning, diagnosticDs, errDsCoreExpr, failWithDs, failDs, discardWarningsDs, askNoErrsDs, @@ -48,7 +48,7 @@ DsMatchContext(..), EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, - -- Levity polymorphism + -- Representation polymorphism dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, -- Trace injection @@ -60,6 +60,7 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Config.Diagnostic import GHC.Hs @@ -79,8 +80,9 @@ import GHC.IfaceToCore +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr ) +import GHC.Tc.Utils.TcMType ( checkForLevPolyX ) import GHC.Builtin.Names @@ -362,29 +364,36 @@ functions are defined with it. The difference in name-strings makes it easier to read debugging output. -Note [Levity polymorphism checking] +Note [Representation polymorphism checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the "Levity Polymorphism" paper (PLDI '17), levity -polymorphism is forbidden in precisely two places: in the type of a bound -term-level argument and in the type of an argument to a function. The paper -explains it more fully, but briefly: expressions in these contexts need to be -stored in registers, and it's hard (read, impossible) to store something -that's levity polymorphic. +According to the "Levity Polymorphism" paper (PLDI '17), +representation polymorphism is forbidden in precisely two places: +in the type of a bound term-level argument, and in the type of an argument +to a function. +Note that the paper doesn't distinguish levity polymorphism, such as + \(v::Levity). \(a::TYPE (BoxedRep v)). \(x::a). expr +from the more general representation polymorphism, as the BoxedRep +constructor of RuntimeRep didn't exist at the time. -We cannot check for bad levity polymorphism conveniently in the type checker, -because we can't tell, a priori, which levity metavariables will be solved. +The paper explains the restrictions more fully, but briefly: +expressions in these contexts need to be stored in registers, and it's +hard (read: impossible) to store something that's representation-polymorphic. + +We cannot check for bad representation polymorphism conveniently +in the type checker, because we can't tell, a priori, which +representation metavariables will be solved. At one point, I (Richard) thought we could check in the zonker, but it's hard to know where precisely are the abstracted variables and the arguments. So we check in the desugarer, the only place where we can see the Core code and still report respectable syntax to the user. This covers the vast majority of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends. -Levity polymorphism is also prohibited in the types of binders, and the +Representation polymorphism is also prohibited in the types of binders, and the desugarer checks for this in GHC-generated Ids. (The zonker handles the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. The newSysLocalDs variant is used in the vast majority of cases where -the binder is obviously not levity polymorphic, omitting the check. -It would be nice to ASSERT that there is no levity polymorphism here, +the binder is obviously not representation-polymorphic, omitting the check. +It would be nice to ASSERT that there is no representation polymorphism here, but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though: Core Lint will catch an error here. @@ -395,10 +404,10 @@ desugarer. There are a few more checks in places where Core is generated outside the -desugarer. For example, in datatype and class declarations, where levity -polymorphism is checked for during validity checking. It would be nice to -have one central place for all this, but that doesn't seem possible while -still reporting nice error messages. +desugarer. For example, in datatype and class declarations, where +representation polymorphism is checked for during validity checking. +It would be nice to have one central place for all this, but that doesn't +seem possible while still reporting nice error messages. -} @@ -419,21 +428,21 @@ newSysLocalDsNoLP = mk_local (fsLit "ds") -- this variant should be used when the caller can be sure that the variable type --- is not levity-polymorphic. It is necessary when the type is knot-tied because --- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking] +-- is not representation-polymorphic. It is necessary when the type +-- is knot-tied because of the fixM used in GHC.HsToCore.Arrows. +-- See Note [Representation polymorphism checking] newSysLocalDs = mkSysLocalM (fsLit "ds") newFailLocalDs = mkSysLocalM (fsLit "fail") -- the fail variable is used only in a situation where we can tell that - -- levity-polymorphism is impossible. + -- representation polymorphism is impossible. newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id] newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t) newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) mk_local :: FastString -> Mult -> Type -> DsM Id -mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> - ppr ty) -- could improve the msg with another - -- parameter indicating context +mk_local fs w ty = do { dsNoLevPoly ty LevityCheckInVarType -- could improve the msg with another + -- parameter indicating context ; mkSysLocalOrCoVarM fs w ty } {- @@ -466,43 +475,27 @@ putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) --- | Emit a diagnostic for the current source location --- NB: Warns whether or not -Wxyz is set -diagnosticDs :: DiagnosticReason -> SDoc -> DsM () -diagnosticDs reason warn +-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning, +-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags. +-- See Note [Discarding Messages] in 'GHC.Types.Error'. +diagnosticDs :: DsMessage -> DsM () +diagnosticDs dsMessage = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $ - DsUnknownMessage $ - mkPlainDiagnostic reason noHints warn + ; !diag_opts <- initDiagOpts <$> getDynFlags + ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } --- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags -warnIfSetDs :: WarningFlag -> SDoc -> DsM () -warnIfSetDs flag warn - = whenWOptM flag $ - diagnosticDs (WarningWithFlag flag) warn - -errDs :: SDoc -> DsM () -errDs err - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $ - DsUnknownMessage $ - mkPlainError noHints err - ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } - -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors. -errDsCoreExpr :: SDoc -> DsM CoreExpr -errDsCoreExpr err - = do { errDs err +errDsCoreExpr :: DsMessage -> DsM CoreExpr +errDsCoreExpr msg + = do { diagnosticDs msg ; return unitExpr } -failWithDs :: SDoc -> DsM a -failWithDs err - = do { errDs err +failWithDs :: DsMessage -> DsM a +failWithDs msg + = do { diagnosticDs msg ; failM } failDs :: DsM a @@ -603,25 +596,26 @@ ; return result } --- | Fail with an error message if the type is levity polymorphic. -dsNoLevPoly :: Type -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty +-- | Fail with an error message if the type is representation-polymorphic. +dsNoLevPoly :: Type -> LevityCheckProvenance -> DsM () +-- See Note [Representation polymorphism checking] +dsNoLevPoly ty provenance = + checkForLevPolyX (\ty -> failWithDs . DsLevityPolyInType ty) provenance ty --- | Check an expression for levity polymorphism, failing if it is --- levity polymorphic. -dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPolyExpr e doc - | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) +-- | Check an expression for representation polymorphism, failing if it is +-- representation-polymorphic. +dsNoLevPolyExpr :: CoreExpr -> LevityExprProvenance -> DsM () +-- See Note [Representation polymorphism checking] +dsNoLevPolyExpr e provenance + | isExprLevPoly e = diagnosticDs (DsLevityPolyInExpr e provenance) | otherwise = return () -- | Runs the thing_inside. If there are no errors, then returns the expr -- given. Otherwise, returns unitExpr. This is useful for doing a bunch --- of levity polymorphism checks and then avoiding making a core App. --- (If we make a core App on a levity polymorphic argument, detecting how --- to handle the let/app invariant might call isUnliftedType, which panics --- on a levity polymorphic type.) +-- of representation polymorphism checks and then avoiding making a core App. +-- (If we make a core App on a representation-polymorphic argument, detecting +-- how to handle the let/app invariant might call isUnliftedType, which panics +-- on a representation-polymorphic type.) -- See #12709 for an example of why this machinery is necessary. dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr dsWhenNoErrs thing_inside mk_expr diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -43,16 +43,15 @@ import GHC.Prelude +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Desugar import GHC.HsToCore.Pmc.Check import GHC.HsToCore.Pmc.Solver -import GHC.HsToCore.Pmc.Ppr import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session -import GHC.Driver.Env import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc @@ -60,12 +59,12 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var (EvVar) -import GHC.Tc.Types import GHC.Tc.Utils.TcType (evVarPred) +import GHC.Tc.Utils.Monad (updTopFlags) import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag -import GHC.Data.IOEnv (updEnv, unsafeInterleaveM) +import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Utils.Monad (mapMaybeM) @@ -95,10 +94,7 @@ -- is one concern, but also a lack of properly set up long-distance information -- might trigger warnings that we normally wouldn't emit. noCheckDs :: DsM a -> DsM a -noCheckDs k = do - dflags <- getDynFlags - let dflags' = foldl' wopt_unset dflags allPmCheckWarnings - updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k +noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings) -- | Check a pattern binding (let, where) for exhaustiveness. pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM () @@ -330,7 +326,7 @@ -- | Issue all the warnings -- (redundancy, inaccessibility, exhaustiveness, redundant bangs). reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM () -reportWarnings dflags ctx@(DsMatchContext kind loc) vars +reportWarnings dflags (DsMatchContext kind loc) vars CheckResult { cr_ret = CIRB { cirb_inacc = inaccessible_rhss , cirb_red = redundant_rhss , cirb_bangs = redundant_bangs } @@ -345,55 +341,26 @@ approx = precision == Approximate when (approx && (exists_u || exists_i)) $ - putSrcSpanDs loc (diagnosticDs WarningWithoutFlag approx_msg) + putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags))) when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnRedundantBangPatterns) - (pprEqn q "has redundant bang")) + putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q)) when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns) - (pprEqn q "is redundant")) + putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q)) when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns) - (pprEqn q "has inaccessible right hand side")) + putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q)) - when exists_u $ putSrcSpanDs loc $ diagnosticDs flag_u_reason $ - pprEqns vars unc_examples + when exists_u $ + putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples)) where flag_i = overlapping dflags kind flag_u = exhaustive dflags kind flag_b = redundantBang dflags - flag_u_reason = maybe WarningWithoutFlag WarningWithFlag (exhaustiveWarningFlag kind) + check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind) maxPatterns = maxUncoveredPatterns dflags - -- Print a single clause (for redundant/with-inaccessible-rhs) - pprEqn q txt = pprContext True ctx (text txt) $ \f -> - f (q <+> matchSeparator kind <+> text "...") - - -- Print several clauses (for uncovered clauses) - pprEqns vars nablas = pprContext False ctx (text "are non-exhaustive") $ \_ -> - case vars of -- See #11245 - [] -> text "Guards do not cover entire pattern space" - _ -> let us = map (\nabla -> pprUncovered nabla vars) nablas - pp_tys = pprQuotedList $ map idType vars - in hang - (text "Patterns of type" <+> pp_tys <+> text "not matched:") - 4 - (vcat (take maxPatterns us) $$ dots maxPatterns us) - - approx_msg = vcat - [ hang - (text "Pattern match checker ran into -fmax-pmcheck-models=" - <> int (maxPmCheckModels dflags) - <> text " limit, so") - 2 - ( bullet <+> text "Redundant clauses might not be reported at all" - $$ bullet <+> text "Redundant clauses might be reported as inaccessible" - $$ bullet <+> text "Patterns reported as unmatched might actually be matched") - , text "Increase the limit or resolve the warnings to suppress this message." ] - getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla] getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas) where @@ -403,26 +370,6 @@ front <- generateInhabitingPatterns vars n nabla back <- go (n - length front) nablas pure (front ++ back) - -dots :: Int -> [a] -> SDoc -dots maxPatterns qs - | qs `lengthExceeds` maxPatterns = text "..." - | otherwise = empty - -pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc -pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun - = vcat [text txt <+> msg, - sep [ text "In" <+> ppr_match <> char ':' - , nest 4 (rest_of_msg_fun pref)]] - where - txt | singular = "Pattern match" - | otherwise = "Pattern match(es)" - - (ppr_match, pref) - = case kind of - FunRhs { mc_fun = L _ fun } - -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) - _ -> (pprMatchContext kind, \ pp -> pp) -- -- * Adding external long-distance information diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -122,17 +122,38 @@ SigPat _ p _ty -> desugarLPat x p - -- See Note [Desugar CoPats] - -- Generally the translation is - -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat - XPat (CoPat wrapper p _ty) - | isIdHsWrapper wrapper -> desugarPat x p - | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p - | otherwise -> do - (y, grds) <- desugarPatV p - wrap_rhs_y <- dsHsWrapper wrapper - pure (PmLet y (wrap_rhs_y (Var x)) : grds) + XPat ext -> case ext of + ExpansionPat orig expansion -> do + dflags <- getDynFlags + case orig of + -- We add special logic for overloaded list patterns. When: + -- - a ViewPat is the expansion of a ListPat, + -- - RebindableSyntax is off, + -- - the type of the pattern is the built-in list type, + -- then we assume that the view function, 'toList', is the identity. + -- This improves pattern-match overload checks, as this will allow + -- the pattern match checker to directly inspect the inner pattern. + -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle). + ListPat {} + | ViewPat arg_ty _lexpr pat <- expansion + , not (xopt LangExt.RebindableSyntax dflags) + , Just _ <- splitListTyConApp_maybe arg_ty + -> desugarLPat x pat + + _ -> desugarPat x expansion + + -- See Note [Desugar CoPats] + -- Generally the translation is + -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat + CoPat wrapper p _ty + | isIdHsWrapper wrapper -> desugarPat x p + | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p + | otherwise -> do + (y, grds) <- desugarPatV p + wrap_rhs_y <- dsHsWrapper wrapper + pure (PmLet y (wrap_rhs_y (Var x)) : grds) + -- (n + k) ===> let b = x >= k, True <- b, let n = x-k NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do b <- mkPmId boolTy @@ -149,36 +170,8 @@ pure $ PmLet y (App fun (Var x)) : grds -- list - ListPat (ListPatTc _elem_ty Nothing) ps -> + ListPat _ ps -> desugarListPat x ps - - -- overloaded list - ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do - dflags <- getDynFlags - case splitListTyConApp_maybe pat_ty of - Just _e_ty - | not (xopt LangExt.RebindableSyntax dflags) - -- Just desugar it as a regular ListPat - -> desugarListPat x pats - _ -> do - y <- mkPmId (mkListTy elem_ty) - grds <- desugarListPat y pats - rhs_y <- dsSyntaxExpr to_list [Var x] - pure $ PmLet y rhs_y : grds - - -- (a) In the presence of RebindableSyntax, we don't know anything about - -- `toList`, we should treat `ListPat` as any other view pattern. - -- - -- (b) In the absence of RebindableSyntax, - -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern - -- as ordinary list pattern. Although we can give an instance - -- `IsList [Int]` (more specific than the default `IsList [a]`), in - -- practice, we almost never do that. We assume the `to_list` is - -- the `toList` from `instance IsList [a]`. - -- - -- - Otherwise, we treat the `ListPat` as ordinary view pattern. - -- - -- See #14547, especially comment#9 and comment#10. ConPat { pat_con = L _ con , pat_args = ps diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs deleted file mode 100644 --- a/compiler/GHC/HsToCore/Pmc/Ppr.hs +++ /dev/null @@ -1,208 +0,0 @@ - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for --- user facing pattern match warnings. -module GHC.HsToCore.Pmc.Ppr ( - pprUncovered - ) where - -import GHC.Prelude - -import GHC.Types.Basic -import GHC.Types.Id -import GHC.Types.Var.Env -import GHC.Types.Unique.DFM -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Builtin.Types -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import Control.Monad.Trans.RWS.CPS -import GHC.Data.Maybe -import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) - -import GHC.HsToCore.Pmc.Types -import GHC.HsToCore.Pmc.Solver - --- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its --- components and refutable shapes associated to any mentioned variables. --- --- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@: --- --- @ --- (Just p) q --- where p is not one of {3, 4} --- q is not one of {0, 5} --- @ --- --- When the set of refutable shapes contains more than 3 elements, the --- additional elements are indicated by "...". -pprUncovered :: Nabla -> [Id] -> SDoc -pprUncovered nabla vas - | isNullUDFM refuts = fsep vec -- there are no refutations - | otherwise = hang (fsep vec) 4 $ - text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts)) - where - init_prec - -- No outer parentheses when it's a unary pattern by assuming lowest - -- precedence - | [_] <- vas = topPrec - | otherwise = appPrec - ppr_action = mapM (pprPmVar init_prec) vas - (vec, renamings) = runPmPpr nabla ppr_action - refuts = prettifyRefuts nabla renamings - --- | Output refutable shapes of a variable in the form of @var is not one of {2, --- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is --- indicated by an ellipsis. -pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc -pprRefutableShapes (var, alts) - = var <+> text "is not one of" <+> format_alts alts - where - format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt - shorten (a:b:c:_:_) = a:b:c:[text "..."] - shorten xs = xs - ppr_alt (PmAltConLike cl) = ppr cl - ppr_alt (PmAltLit lit) = ppr lit - -{- 1. Literals -~~~~~~~~~~~~~~ -Starting with a function definition like: - - f :: Int -> Bool - f 5 = True - f 6 = True - -The uncovered set looks like: - { var |> var /= 5, var /= 6 } - -Yet, we would like to print this nicely as follows: - x , where x not one of {5,6} - -Since these variables will be shown to the programmer, we give them better names -(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'. - -2. Residual Constraints -~~~~~~~~~~~~~~~~~~~~~~~ -Unhandled constraints that refer to HsExpr are typically ignored by the solver -(it does not even substitute in HsExpr so they are even printed as wildcards). -Additionally, the oracle returns a substitution if it succeeds so we apply this -substitution to the vectors before printing them out (see function `pprOne' in -"GHC.HsToCore.Pmc") to be more precise. --} - --- | Extract and assigns pretty names to constraint variables with refutable --- shapes. -prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon]) -prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList - where - attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x)) - - -type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a - --- Try nice names p,q,r,s,t before using the (ugly) t_i -nameList :: [SDoc] -nameList = map text ["p","q","r","s","t"] ++ - [ text ('t':show u) | u <- [(0 :: Int)..] ] - -runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc)) -runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of - (a, (renamings, _), _) -> (a, renamings) - --- | Allocates a new, clean name for the given 'Id' if it doesn't already have --- one. -getCleanName :: Id -> PmPprM SDoc -getCleanName x = do - (renamings, name_supply) <- get - let (clean_name:name_supply') = name_supply - case lookupDVarEnv renamings x of - Just (_, nm) -> pure nm - Nothing -> do - put (extendDVarEnv renamings x (x, clean_name), name_supply') - pure clean_name - -checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached -checkRefuts x = do - nabla <- ask - case lookupRefuts nabla x of - [] -> pure Nothing -- Will just be a wildcard later on - _ -> Just <$> getCleanName x - --- | Pretty print a variable, but remember to prettify the names of the variables --- that refer to neg-literals. The ones that cannot be shown are printed as --- underscores. -pprPmVar :: PprPrec -> Id -> PmPprM SDoc -pprPmVar prec x = do - nabla <- ask - case lookupSolution nabla x of - Just (PACA alt _tvs args) -> pprPmAltCon prec alt args - Nothing -> fromMaybe underscore <$> checkRefuts x - -pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc -pprPmAltCon _prec (PmAltLit l) _ = pure (ppr l) -pprPmAltCon prec (PmAltConLike cl) args = do - nabla <- ask - pprConLike nabla prec cl args - -pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc -pprConLike nabla _prec cl args - | Just pm_expr_list <- pmExprAsList nabla (PmAltConLike cl) args - = case pm_expr_list of - NilTerminated list -> - brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list - WcVarTerminated pref x -> - parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x]) -pprConLike _nabla _prec (RealDataCon con) args - | isUnboxedTupleDataCon con - , let hash_parens doc = text "(#" <+> doc <+> text "#)" - = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args - | isTupleDataCon con - = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args -pprConLike _nabla prec cl args - | conLikeIsInfix cl = case args of - [x, y] -> do x' <- pprPmVar funPrec x - y' <- pprPmVar funPrec y - return (cparen (prec > opPrec) (x' <+> ppr cl <+> y')) - -- can it be infix but have more than two arguments? - list -> pprPanic "pprConLike:" (ppr list) - | null args = return (ppr cl) - | otherwise = do args' <- mapM (pprPmVar appPrec) args - return (cparen (prec > funPrec) (fsep (ppr cl : args'))) - --- | The result of 'pmExprAsList'. -data PmExprList - = NilTerminated [Id] - | WcVarTerminated (NonEmpty Id) Id - --- | Extract a list of 'Id's out of a sequence of cons cells, optionally --- terminated by a wildcard variable instead of @[]@. Some examples: --- --- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular, --- @[]@-terminated list. Should be pretty-printed as @[1,2]@. --- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix --- ending in a wildcard variable x (of list type). Should be pretty-printed as --- (1:2:_). --- * @pmExprAsList [] == Just ('NilTerminated' [])@ -pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList -pmExprAsList nabla = go_con [] - where - go_var rev_pref x - | Just (PACA alt _tvs args) <- lookupSolution nabla x - = go_con rev_pref alt args - go_var rev_pref x - | Just pref <- nonEmpty (reverse rev_pref) - = Just (WcVarTerminated pref x) - go_var _ _ - = Nothing - - go_con rev_pref (PmAltConLike (RealDataCon c)) es - | c == nilDataCon - = assert (null es) $ Just (NilTerminated (reverse rev_pref)) - | c == consDataCon - = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1) - go_con _ _ _ - = Nothing diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -23,7 +23,6 @@ module GHC.HsToCore.Pmc.Solver ( Nabla, Nablas(..), initNablas, - lookupRefuts, lookupSolution, PhiCt(..), PhiCts, addPhiCtNablas, @@ -510,58 +509,9 @@ In order to avoid this pitfall, we need to normalise the type passed to pmTopNormaliseType, using the constraint solver to solve for any local equalities (such as i ~ Int) that may be in scope. --} ------------------------ --- * Looking up VarInfo - -emptyRCM :: ResidualCompleteMatches -emptyRCM = RCM Nothing Nothing - -emptyVarInfo :: Id -> VarInfo -emptyVarInfo x - = VI - { vi_id = x - , vi_pos = [] - , vi_neg = emptyPmAltConSet - -- Case (3) in Note [Strict fields and fields of unlifted type] - , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot - , vi_rcm = emptyRCM - } - -lookupVarInfo :: TmState -> Id -> VarInfo --- (lookupVarInfo tms x) tells what we know about 'x' -lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x) - --- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks --- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the --- returned @y@ doesn't have a positive newtype constructor constraint --- associated with it (yet). The 'VarInfo' returned is that of @y@'s --- representative. --- --- Careful, this means that @idType x@ might be different to @idType y@, even --- modulo type normalisation! --- --- See also Note [Coverage checking Newtype matches]. -lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo) -lookupVarInfoNT ts x = case lookupVarInfo ts x of - VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y - res -> (x, res) - where - as_newtype = listToMaybe . mapMaybe go - go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]} - | isNewDataCon dc = Just y - go _ = Nothing - -trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla) -trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x - = set_vi <$> f (lookupVarInfo ts x) - where - set_vi (a, vi') = - (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } }) - -{- Note [Coverage checking Newtype matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Coverage checking Newtype matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation testing purposes (e.g. at construction sites), they behave rather like a DataCon @@ -588,28 +538,6 @@ where you can find the solution in a perhaps more digestible format. -} ------------------------------------------------- --- * Exported utility functions querying 'Nabla' - -lookupRefuts :: Nabla -> Id -> [PmAltCon] --- Unfortunately we need the extra bit of polymorphism and the unfortunate --- duplication of lookupVarInfo here. -lookupRefuts MkNabla{ nabla_tm_st = ts } x = - pmAltConSetElems $ vi_neg $ lookupVarInfo ts x - -isDataConSolution :: PmAltConApp -> Bool -isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True -isDataConSolution _ = False - --- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from --- possibly many, preferring 'RealDataCon' solutions whenever possible. -lookupSolution :: Nabla -> Id -> Maybe PmAltConApp -lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of - [] -> Nothing - pos - | Just sol <- find isDataConSolution pos -> Just sol - | otherwise -> Just (head pos) - ------------------------- -- * Adding φ constraints -- @@ -1414,7 +1342,7 @@ dataConUnliftedFieldTys :: DataCon -> [Type] dataConUnliftedFieldTys = - -- A levity polymorphic field requires an inhabitation test, hence compare to + -- A representation-polymorphic field requires an inhabitation test, hence compare to -- @Just True@ filter ((== Just True) . isLiftedType_maybe) . map scaledThing . dataConOrigArgTys diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs deleted file mode 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ /dev/null @@ -1,700 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} - -{-# LANGUAGE ScopedTypeVariables #-} - --- | Domain types used in "GHC.HsToCore.Pmc.Solver". --- The ultimate goal is to define 'Nabla', which models normalised refinement --- types from the paper --- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989). -module GHC.HsToCore.Pmc.Solver.Types ( - - -- * Normalised refinement types - BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..), - Nabla(..), Nablas(..), initNablas, - - -- ** Caching residual COMPLETE sets - CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised, - - -- ** Representations for Literals and AltCons - PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType, - isPmAltConMatchStrict, pmAltConImplBangs, - - -- *** PmAltConSet - PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet, - extendPmAltConSet, pmAltConSetElems, - - -- *** Equality on 'PmAltCon's - PmEquality(..), eqPmAltCon, - - -- *** Operations on 'PmLit' - literalToPmLit, negatePmLit, overloadPmLit, - pmLitAsStringLit, coreExprAsPmLit - - ) where - -import GHC.Prelude - -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Types.Id -import GHC.Types.Var.Set -import GHC.Types.Unique.DSet -import GHC.Types.Unique.SDFM -import GHC.Types.Name -import GHC.Core.DataCon -import GHC.Core.ConLike -import GHC.Utils.Outputable -import GHC.Utils.Panic.Plain -import GHC.Data.List.SetOps (unionLists) -import GHC.Data.Maybe -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Types.Literal -import GHC.Core -import GHC.Core.Map.Expr -import GHC.Core.Utils (exprType) -import GHC.Builtin.Names -import GHC.Builtin.Types -import GHC.Builtin.Types.Prim -import GHC.Tc.Solver.InertSet (InertSet, emptyInert) -import GHC.Tc.Utils.TcType (isStringTy) -import GHC.Types.CompleteMatch (CompleteMatch(..)) -import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit - , fractionalLitFromRational - , FractionalExponentBase(..)) -import Numeric (fromRat) -import Data.Foldable (find) -import Data.Ratio -import GHC.Real (Ratio(..)) -import qualified Data.Semigroup as Semi - --- import GHC.Driver.Ppr - --- --- * Normalised refinement types --- - --- | A normalised refinement type ∇ (\"nabla\"), comprised of an inert set of --- canonical (i.e. mutually compatible) term and type constraints that form the --- refinement type's predicate. -data Nabla - = MkNabla - { nabla_ty_st :: !TyState - -- ^ Type oracle; things like a~Int - , nabla_tm_st :: !TmState - -- ^ Term oracle; things like x~Nothing - } - --- | An initial nabla that is always satisfiable -initNabla :: Nabla -initNabla = MkNabla initTyState initTmState - -instance Outputable Nabla where - ppr nabla = hang (text "Nabla") 2 $ vcat [ - -- intentionally formatted this way enable the dev to comment in only - -- the info they need - ppr (nabla_tm_st nabla), - ppr (nabla_ty_st nabla) - ] - --- | A disjunctive bag of 'Nabla's, representing a refinement type. -newtype Nablas = MkNablas (Bag Nabla) - -initNablas :: Nablas -initNablas = MkNablas (unitBag initNabla) - -instance Outputable Nablas where - ppr (MkNablas nablas) = ppr nablas - -instance Semigroup Nablas where - MkNablas l <> MkNablas r = MkNablas (l `unionBags` r) - -instance Monoid Nablas where - mempty = MkNablas emptyBag - --- | The type oracle state. An 'GHC.Tc.Solver.Monad.InertSet' that we --- incrementally add local type constraints to, together with a sequence --- number that counts the number of times we extended it with new facts. -data TyState = TySt { ty_st_n :: !Int, ty_st_inert :: !InertSet } - --- | Not user-facing. -instance Outputable TyState where - ppr (TySt n inert) = ppr n <+> ppr inert - -initTyState :: TyState -initTyState = TySt 0 emptyInert - --- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These --- entries are possibly shared when we figure out that two variables must be --- equal, thus represent the same set of values. --- --- See Note [TmState invariants] in "GHC.HsToCore.Pmc.Solver". -data TmState - = TmSt - { ts_facts :: !(UniqSDFM Id VarInfo) - -- ^ Facts about term variables. Deterministic env, so that we generate - -- deterministic error messages. - , ts_reps :: !(CoreMap Id) - -- ^ An environment for looking up whether we already encountered semantically - -- equivalent expressions that we want to represent by the same 'Id' - -- representative. - , ts_dirty :: !DIdSet - -- ^ Which 'VarInfo' needs to be checked for inhabitants because of new - -- negative constraints (e.g. @x ≁ ⊥@ or @x ≁ K@). - } - --- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@, --- and negative ('vi_neg') facts, like "x is not (:)". --- Also caches the type ('vi_ty'), the 'ResidualCompleteMatches' of a COMPLETE set --- ('vi_rcm'). --- --- Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.Pmc.Solver". -data VarInfo - = VI - { vi_id :: !Id - -- ^ The 'Id' in question. Important for adding new constraints relative to - -- this 'VarInfo' when we don't easily have the 'Id' available. - - , vi_pos :: ![PmAltConApp] - -- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all - -- at the same time (i.e. conjunctive). We need a list because of nested - -- pattern matches involving pattern synonym - -- case x of { Just y -> case x of PatSyn z -> ... } - -- However, no more than one RealDataCon in the list, otherwise contradiction - -- because of generativity. - - , vi_neg :: !PmAltConSet - -- ^ Negative info: A list of 'PmAltCon's that it cannot match. - -- Example, assuming - -- - -- @ - -- data T = Leaf Int | Branch T T | Node Int T - -- @ - -- - -- then @x ≁ [Leaf, Node]@ means that @x@ cannot match a @Leaf@ or @Node@, - -- and hence can only match @Branch@. Is orthogonal to anything from 'vi_pos', - -- in the sense that 'eqPmAltCon' returns @PossiblyOverlap@ for any pairing - -- between 'vi_pos' and 'vi_neg'. - - -- See Note [Why record both positive and negative info?] - -- It's worth having an actual set rather than a simple association list, - -- because files like Cabal's `LicenseId` define relatively huge enums - -- that lead to quadratic or worse behavior. - - , vi_bot :: BotInfo - -- ^ Can this variable be ⊥? Models (mutually contradicting) @x ~ ⊥@ and - -- @x ≁ ⊥@ constraints. E.g. - -- * 'MaybeBot': Don't know; Neither @x ~ ⊥@ nor @x ≁ ⊥@. - -- * 'IsBot': @x ~ ⊥@ - -- * 'IsNotBot': @x ≁ ⊥@ - - , vi_rcm :: !ResidualCompleteMatches - -- ^ A cache of the associated COMPLETE sets. At any time a superset of - -- possible constructors of each COMPLETE set. So, if it's not in here, we - -- can't possibly match on it. Complementary to 'vi_neg'. We still need it - -- to recognise completion of a COMPLETE set efficiently for large enums. - } - -data PmAltConApp - = PACA - { paca_con :: !PmAltCon - , paca_tvs :: ![TyVar] - , paca_ids :: ![Id] - } - --- | See 'vi_bot'. -data BotInfo - = IsBot - | IsNotBot - | MaybeBot - deriving Eq - -instance Outputable PmAltConApp where - ppr PACA{paca_con = con, paca_tvs = tvs, paca_ids = ids} = - hsep (ppr con : map ((char '@' <>) . ppr) tvs ++ map ppr ids) - -instance Outputable BotInfo where - ppr MaybeBot = underscore - ppr IsBot = text "~⊥" - ppr IsNotBot = text "≁⊥" - --- | Not user-facing. -instance Outputable TmState where - ppr (TmSt state reps dirty) = ppr state $$ ppr reps $$ ppr dirty - --- | Not user-facing. -instance Outputable VarInfo where - ppr (VI x pos neg bot cache) - = braces (hcat (punctuate comma [pp_x, pp_pos, pp_neg, ppr bot, pp_cache])) - where - pp_x = ppr x <> dcolon <> ppr (idType x) - pp_pos - | [] <- pos = underscore - | [p] <- pos = char '~' <> ppr p -- suppress outer [_] if singleton - | otherwise = char '~' <> ppr pos - pp_neg - | isEmptyPmAltConSet neg = underscore - | otherwise = char '≁' <> ppr neg - pp_cache - | RCM Nothing Nothing <- cache = underscore - | otherwise = ppr cache - --- | Initial state of the term oracle. -initTmState :: TmState -initTmState = TmSt emptyUSDFM emptyCoreMap emptyDVarSet - --- | A data type that caches for the 'VarInfo' of @x@ the results of querying --- 'dsGetCompleteMatches' and then striking out all occurrences of @K@ for --- which we already know @x ≁ K@ from these sets. --- --- For motivation, see Section 5.3 in Lower Your Guards. --- See also Note [Implementation of COMPLETE pragmas] -data ResidualCompleteMatches - = RCM - { rcm_vanilla :: !(Maybe CompleteMatch) - -- ^ The residual set for the vanilla COMPLETE set from the data defn. - -- Tracked separately from 'rcm_pragmas', because it might only be - -- known much later (when we have enough type information to see the 'TyCon' - -- of the match), or not at all even. Until that happens, it is 'Nothing'. - , rcm_pragmas :: !(Maybe [CompleteMatch]) - -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are - -- visible when compiling this module. Querying that set with - -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing' - -- until first needed in a 'DsM' context. - } - -getRcm :: ResidualCompleteMatches -> [CompleteMatch] -getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas - -isRcmInitialised :: ResidualCompleteMatches -> Bool -isRcmInitialised (RCM vanilla pragmas) = isJust vanilla && isJust pragmas - -instance Outputable ResidualCompleteMatches where - -- formats as "[{Nothing,Just},{P,Q}]" - ppr rcm = ppr (getRcm rcm) - --------------------------------------------------------------------------------- --- The rest is just providing an IR for (overloaded!) literals and AltCons that --- sits between Hs and Core. We need a reliable way to detect and determine --- equality between them, which is impossible with Hs (too expressive) and with --- Core (no notion of overloaded literals, and even plain 'Int' literals are --- actually constructor apps). Also String literals are troublesome. - --- | Literals (simple and overloaded ones) for pattern match checking. --- --- See Note [Undecidable Equality for PmAltCons] -data PmLit = PmLit - { pm_lit_ty :: Type - , pm_lit_val :: PmLitValue } - -data PmLitValue - = PmLitInt Integer - | PmLitRat Rational - | PmLitChar Char - -- We won't actually see PmLitString in the oracle since we desugar strings to - -- lists - | PmLitString FastString - | PmLitOverInt Int {- How often Negated? -} Integer - | PmLitOverRat Int {- How often Negated? -} FractionalLit - | PmLitOverString FastString - --- | Undecidable semantic equality result. --- See Note [Undecidable Equality for PmAltCons] -data PmEquality - = Equal - | Disjoint - | PossiblyOverlap - deriving (Eq, Show) - --- | When 'PmEquality' can be decided. @True <=> Equal@, @False <=> Disjoint@. -decEquality :: Bool -> PmEquality -decEquality True = Equal -decEquality False = Disjoint - --- | Undecidable equality for values represented by 'PmLit's. --- See Note [Undecidable Equality for PmAltCons] --- --- * @Just True@ ==> Surely equal --- * @Just False@ ==> Surely different (non-overlapping, even!) --- * @Nothing@ ==> Equality relation undecidable -eqPmLit :: PmLit -> PmLit -> PmEquality -eqPmLit (PmLit t1 v1) (PmLit t2 v2) - -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined - | not (t1 `eqType` t2) = Disjoint - | otherwise = go v1 v2 - where - go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2) - go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2) - go (PmLitChar c1) (PmLitChar c2) = decEquality (c1 == c2) - go (PmLitString s1) (PmLitString s2) = decEquality (s1 == s2) - go (PmLitOverInt n1 i1) (PmLitOverInt n2 i2) - | n1 == n2 && i1 == i2 = Equal - go (PmLitOverRat n1 r1) (PmLitOverRat n2 r2) - | n1 == n2 && r1 == r2 = Equal - go (PmLitOverString s1) (PmLitOverString s2) - | s1 == s2 = Equal - go _ _ = PossiblyOverlap - --- | Syntactic equality. -instance Eq PmLit where - a == b = eqPmLit a b == Equal - --- | Type of a 'PmLit' -pmLitType :: PmLit -> Type -pmLitType (PmLit ty _) = ty - --- | Undecidable equality for values represented by 'ConLike's. --- See Note [Undecidable Equality for PmAltCons]. --- 'PatSynCon's aren't enforced to be generative, so two syntactically different --- 'PatSynCon's might match the exact same values. Without looking into and --- reasoning about the pattern synonym's definition, we can't decide if their --- sets of matched values is different. --- --- * @Just True@ ==> Surely equal --- * @Just False@ ==> Surely different (non-overlapping, even!) --- * @Nothing@ ==> Equality relation undecidable -eqConLike :: ConLike -> ConLike -> PmEquality -eqConLike (RealDataCon dc1) (RealDataCon dc2) = decEquality (dc1 == dc2) -eqConLike (PatSynCon psc1) (PatSynCon psc2) - | psc1 == psc2 - = Equal -eqConLike _ _ = PossiblyOverlap - --- | Represents the head of a match against a 'ConLike' or literal. --- Really similar to 'GHC.Core.AltCon'. -data PmAltCon = PmAltConLike ConLike - | PmAltLit PmLit - -data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] - -emptyPmAltConSet :: PmAltConSet -emptyPmAltConSet = PACS emptyUniqDSet [] - -isEmptyPmAltConSet :: PmAltConSet -> Bool -isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits - --- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to --- the given 'PmAltCon' according to 'eqPmAltCon'. -elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool -elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls -elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits - -extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet -extendPmAltConSet (PACS cls lits) (PmAltConLike cl) - = PACS (addOneToUniqDSet cls cl) lits -extendPmAltConSet (PACS cls lits) (PmAltLit lit) - = PACS cls (unionLists lits [lit]) - -pmAltConSetElems :: PmAltConSet -> [PmAltCon] -pmAltConSetElems (PACS cls lits) - = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits - -instance Outputable PmAltConSet where - ppr = ppr . pmAltConSetElems - --- | We can't in general decide whether two 'PmAltCon's match the same set of --- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a --- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'. --- See Note [Undecidable Equality for PmAltCons]. --- --- * @Just True@ ==> Surely equal --- * @Just False@ ==> Surely different (non-overlapping, even!) --- * @Nothing@ ==> Equality relation undecidable --- --- Examples (omitting some constructor wrapping): --- --- * @eqPmAltCon (LitInt 42) (LitInt 1) == Just False@: Lit equality is --- decidable --- * @eqPmAltCon (DataCon A) (DataCon B) == Just False@: DataCon equality is --- decidable --- * @eqPmAltCon (LitOverInt 42) (LitOverInt 1) == Nothing@: OverLit equality --- is undecidable --- * @eqPmAltCon (PatSyn PA) (PatSyn PB) == Nothing@: PatSyn equality is --- undecidable --- * @eqPmAltCon (DataCon I#) (LitInt 1) == Nothing@: DataCon to Lit --- comparisons are undecidable without reasoning about the wrapped @Int#@ --- * @eqPmAltCon (LitOverInt 1) (LitOverInt 1) == Just True@: We assume --- reflexivity for overloaded literals --- * @eqPmAltCon (PatSyn PA) (PatSyn PA) == Just True@: We assume reflexivity --- for Pattern Synonyms -eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality -eqPmAltCon (PmAltConLike cl1) (PmAltConLike cl2) = eqConLike cl1 cl2 -eqPmAltCon (PmAltLit l1) (PmAltLit l2) = eqPmLit l1 l2 -eqPmAltCon _ _ = PossiblyOverlap - --- | Syntactic equality. -instance Eq PmAltCon where - a == b = eqPmAltCon a b == Equal - --- | Type of a 'PmAltCon' -pmAltConType :: PmAltCon -> [Type] -> Type -pmAltConType (PmAltLit lit) _arg_tys = assert (null _arg_tys ) $ pmLitType lit -pmAltConType (PmAltConLike con) arg_tys = conLikeResTy con arg_tys - --- | Is a match on this constructor forcing the match variable? --- True of data constructors, literals and pattern synonyms (#17357), but not of --- newtypes. --- See Note [Coverage checking Newtype matches] in "GHC.HsToCore.Pmc.Solver". -isPmAltConMatchStrict :: PmAltCon -> Bool -isPmAltConMatchStrict PmAltLit{} = True -isPmAltConMatchStrict (PmAltConLike PatSynCon{}) = True -- #17357 -isPmAltConMatchStrict (PmAltConLike (RealDataCon dc)) = not (isNewDataCon dc) - -pmAltConImplBangs :: PmAltCon -> [HsImplBang] -pmAltConImplBangs PmAltLit{} = [] -pmAltConImplBangs (PmAltConLike con) = conLikeImplBangs con - -{- Note [Undecidable Equality for PmAltCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Equality on overloaded literals is undecidable in the general case. Consider -the following example: - - instance Num Bool where - ... - fromInteger 0 = False -- C-like representation of booleans - fromInteger _ = True - - f :: Bool -> () - f 1 = () -- Clause A - f 2 = () -- Clause B - -Clause B is redundant but to detect this, we must decide the constraint: -@fromInteger 2 ~ fromInteger 1@ which means that we -have to look through function @fromInteger@, whose implementation could -be anything. This poses difficulties for: - -1. The expressive power of the check. - We cannot expect a reasonable implementation of pattern matching to detect - that @fromInteger 2 ~ fromInteger 1@ is True, unless we unfold function - fromInteger. This puts termination at risk and is undecidable in the - general case. - -2. Error messages/Warnings. - What should our message for @f@ above be? A reasonable approach would be - to issue: - - Pattern matches are (potentially) redundant: - f 2 = ... under the assumption that 1 == 2 - - but seems to complex and confusing for the user. - -We choose to equate only obviously equal overloaded literals, in all other cases -we signal undecidability by returning Nothing from 'eqPmAltCons'. We do -better for non-overloaded literals, because we know their fromInteger/fromString -implementation is actually injective, allowing us to simplify the constraint -@fromInteger 1 ~ fromInteger 2@ to @1 ~ 2@, which is trivially unsatisfiable. - -The impact of this treatment of overloaded literals is the following: - - * Redundancy checking is rather conservative, since it cannot see that clause - B above is redundant. - - * We have instant equality check for overloaded literals (we do not rely on - the term oracle which is rather expensive, both in terms of performance and - memory). This significantly improves the performance of functions `covered` - `uncovered` and `divergent` in "GHC.HsToCore.Pmc" and effectively addresses - #11161. - - * The warnings issued are simpler. - -Similar reasoning applies to pattern synonyms: In contrast to data constructors, -which are generative, constraints like F a ~ G b for two different pattern -synonyms F and G aren't immediately unsatisfiable. We assume F a ~ F a, though. --} - -literalToPmLit :: Type -> Literal -> Maybe PmLit -literalToPmLit ty l = PmLit ty <$> go l - where - go (LitChar c) = Just (PmLitChar c) - go (LitFloat r) = Just (PmLitRat r) - go (LitDouble r) = Just (PmLitRat r) - go (LitString s) = Just (PmLitString (mkFastStringByteString s)) - go (LitNumber _ i) = Just (PmLitInt i) - go _ = Nothing - -negatePmLit :: PmLit -> Maybe PmLit -negatePmLit (PmLit ty v) = PmLit ty <$> go v - where - go (PmLitInt i) = Just (PmLitInt (-i)) - go (PmLitRat r) = Just (PmLitRat (-r)) - go (PmLitOverInt n i) = Just (PmLitOverInt (n+1) i) - go (PmLitOverRat n r) = Just (PmLitOverRat (n+1) r) - go _ = Nothing - -overloadPmLit :: Type -> PmLit -> Maybe PmLit -overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v - where - go (PmLitInt i) = Just (PmLitOverInt 0 i) - go (PmLitRat r) = Just $! PmLitOverRat 0 $! fractionalLitFromRational r - go (PmLitString s) - | ty `eqType` stringTy = Just v - | otherwise = Just (PmLitOverString s) - go ovRat@PmLitOverRat{} = Just ovRat - go _ = Nothing - -pmLitAsStringLit :: PmLit -> Maybe FastString -pmLitAsStringLit (PmLit _ (PmLitString s)) = Just s -pmLitAsStringLit _ = Nothing - -coreExprAsPmLit :: CoreExpr -> Maybe PmLit --- coreExprAsPmLit e | pprTrace "coreExprAsPmLit" (ppr e) False = undefined -coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e -coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l -coreExprAsPmLit e = case collectArgs e of - (Var x, [Lit l]) - | Just dc <- isDataConWorkId_maybe x - , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon] - -> literalToPmLit (exprType e) l - (Var x, [_ty, Lit n, Lit d]) - | Just dc <- isDataConWorkId_maybe x - , dataConName dc == ratioDataConName - -- HACK: just assume we have a literal double. This case only occurs for - -- overloaded lits anyway, so we immediately override type information - -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d)) - (Var x, args) - -- See Note [Detecting overloaded literals with -XRebindableSyntax] - | is_rebound_name x fromIntegerName - , [Lit l] <- dropWhile (not . is_lit) args - -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e) - (Var x, args) - -- See Note [Detecting overloaded literals with -XRebindableSyntax] - -- fromRational - | is_rebound_name x fromRationalName - , [r] <- dropWhile (not . is_ratio) args - -> coreExprAsPmLit r >>= overloadPmLit (exprType e) - - --Rationals with large exponents - (Var x, args) - -- See Note [Detecting overloaded literals with -XRebindableSyntax] - -- See Note [Dealing with rationals with large exponents] - -- mkRationalBase* - | Just exp_base <- is_larg_exp_ratio x - , [r, Lit exp] <- dropWhile (not . is_ratio) args - , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r - , Just dc <- isDataConWorkId_maybe x - , dataConName dc == ratioDataConName - -> do - n' <- isLitValue_maybe n - d' <- isLitValue_maybe d - exp' <- isLitValue_maybe exp - let rational = (abs n') :% d' - let neg = if n' < 0 then 1 else 0 - let frac = mkFractionalLit NoSourceText False rational exp' exp_base - Just $ PmLit (exprType e) (PmLitOverRat neg frac) - - (Var x, args) - | is_rebound_name x fromStringName - -- See Note [Detecting overloaded literals with -XRebindableSyntax] - , s:_ <- filter (isStringTy . exprType) $ filter isValArg args - -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings - -> coreExprAsPmLit s >>= overloadPmLit (exprType e) - -- These last two cases handle proper String literals - (Var x, [Type ty]) - | Just dc <- isDataConWorkId_maybe x - , dc == nilDataCon - , ty `eqType` charTy - -> literalToPmLit stringTy (mkLitString "") - (Var x, [Lit l]) - | idName x `elem` [unpackCStringName, unpackCStringUtf8Name] - -> literalToPmLit stringTy l - - _ -> Nothing - where - is_lit Lit{} = True - is_lit _ = False - is_ratio (Type _) = False - is_ratio r - | Just (tc, _) <- splitTyConApp_maybe (exprType r) - = tyConName tc == ratioTyConName - | otherwise - = False - is_larg_exp_ratio x - | is_rebound_name x mkRationalBase10Name - = Just Base10 - | is_rebound_name x mkRationalBase2Name - = Just Base2 - | otherwise - = Nothing - - - -- See Note [Detecting overloaded literals with -XRebindableSyntax] - is_rebound_name :: Id -> Name -> Bool - is_rebound_name x n = getOccFS (idName x) == getOccFS n - -{- Note [Detecting overloaded literals with -XRebindableSyntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, we'd find e.g. overloaded string literals by comparing the -application head of an expression to `fromStringName`. But that doesn't work -with -XRebindableSyntax: The `Name` of a user-provided `fromString` function is -different to `fromStringName`, which lives in a certain module, etc. - -There really is no other way than to compare `OccName`s and guess which -argument is the actual literal string (we assume it's the first argument of -type `String`). - -The same applies to other overloaded literals, such as overloaded rationals -(`fromRational`)and overloaded integer literals (`fromInteger`). - -Note [Dealing with rationals with large exponents] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rationals with large exponents are *not* desugared to -a simple rational. As that would require us to compute -their value which can be expensive. Rather they desugar -to an expression. For example 1e1000 will desugar to an -expression of the form: `mkRationalWithExponentBase10 (1 :% 1) 1000` - -Only overloaded literals desugar to this form however, so we -we can just return a overloaded rational literal. - -The most complex case is if we have RebindableSyntax enabled. -By example if we have a pattern like this: `f 3.3 = True` - -It will desugar to: - fromRational - [TYPE: Rational, mkRationalBase10 (:% @Integer 10 1) (-1)] - -The fromRational is properly detected as an overloaded Rational by -coreExprAsPmLit and it's general code for detecting overloaded rationals. -See Note [Detecting overloaded literals with -XRebindableSyntax]. - -This case then recurses into coreExprAsPmLit passing only the expression -`mkRationalBase10 (:% @Integer 10 1) (-1)`. Which is caught by rationals -with large exponents case. This will return a `PmLitOverRat` literal. - -Which is then passed to overloadPmLit which simply returns it as-is since -it's already overloaded. - --} - -instance Outputable PmLitValue where - ppr (PmLitInt i) = ppr i - ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough - ppr (PmLitChar c) = pprHsChar c - ppr (PmLitString s) = pprHsString s - ppr (PmLitOverInt n i) = minuses n (ppr i) - ppr (PmLitOverRat n r) = minuses n (ppr r) - ppr (PmLitOverString s) = pprHsString s - --- Take care of negated literals -minuses :: Int -> SDoc -> SDoc -minuses n sdoc = iterate (\sdoc -> parens (char '-' <> sdoc)) sdoc !! n - -instance Outputable PmLit where - ppr (PmLit ty v) = ppr v <> suffix - where - -- Some ad-hoc hackery for displaying proper lit suffixes based on type - tbl = [ (intPrimTy, primIntSuffix) - , (int64PrimTy, primInt64Suffix) - , (wordPrimTy, primWordSuffix) - , (word64PrimTy, primWord64Suffix) - , (charPrimTy, primCharSuffix) - , (floatPrimTy, primFloatSuffix) - , (doublePrimTy, primDoubleSuffix) ] - suffix = fromMaybe empty (snd <$> find (eqType ty . fst) tbl) - -instance Outputable PmAltCon where - ppr (PmAltConLike cl) = ppr cl - ppr (PmAltLit l) = ppr l - -instance Outputable PmEquality where - ppr = text . show diff --git a/compiler/GHC/HsToCore/Pmc/Types.hs b/compiler/GHC/HsToCore/Pmc/Types.hs deleted file mode 100644 --- a/compiler/GHC/HsToCore/Pmc/Types.hs +++ /dev/null @@ -1,238 +0,0 @@ - -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -{- -Author: George Karachalias - Sebastian Graf --} - --- | Types used through-out pattern match checking. This module is mostly there --- to be imported from "GHC.HsToCore.Types". The exposed API is that of --- "GHC.HsToCore.Pmc". --- --- These types model the paper --- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989). -module GHC.HsToCore.Pmc.Types ( - -- * LYG syntax - - -- ** Guard language - SrcInfo(..), PmGrd(..), GrdVec(..), - - -- ** Guard tree language - PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..), - - -- * Coverage Checking types - RedSets (..), Precision (..), CheckResult (..), - - -- * Pre and post coverage checking synonyms - Pre, Post, - - -- * Normalised refinement types - module GHC.HsToCore.Pmc.Solver.Types - - ) where - -import GHC.Prelude - -import GHC.HsToCore.Pmc.Solver.Types - -import GHC.Data.OrdList -import GHC.Types.Id -import GHC.Types.Var (EvVar) -import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Core.Type -import GHC.Core - -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import qualified Data.Semigroup as Semi - --- --- * Guard language --- - --- | A very simple language for pattern guards. Let bindings, bang patterns, --- and matching variables against flat constructor patterns. --- The LYG guard language. -data PmGrd - = -- | @PmCon x K dicts args@ corresponds to a @K dicts args <- x@ guard. - -- The @args@ are bound in this construct, the @x@ is just a use. - -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'. - PmCon { - pm_id :: !Id, - pm_con_con :: !PmAltCon, - pm_con_tvs :: ![TyVar], - pm_con_dicts :: ![EvVar], - pm_con_args :: ![Id] - } - - -- | @PmBang x@ corresponds to a @seq x True@ guard. - -- If the extra 'SrcInfo' is present, the bang guard came from a source - -- bang pattern, in which case we might want to report it as redundant. - -- See Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check. - | PmBang { - pm_id :: !Id, - _pm_loc :: !(Maybe SrcInfo) - } - - -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually - -- /binds/ @x@. - | PmLet { - pm_id :: !Id, - _pm_let_expr :: !CoreExpr - } - --- | Should not be user-facing. -instance Outputable PmGrd where - ppr (PmCon x alt _tvs _con_dicts con_args) - = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x] - ppr (PmBang x _loc) = char '!' <> ppr x - ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr] - --- --- * Guard tree language --- - --- | Means by which we identify a source construct for later pretty-printing in --- a warning message. 'SDoc' for the equation to show, 'Located' for the --- location. -newtype SrcInfo = SrcInfo (Located SDoc) - --- | A sequence of 'PmGrd's. -newtype GrdVec = GrdVec [PmGrd] - --- | A guard tree denoting 'MatchGroup'. -newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p)) - --- | A guard tree denoting 'Match': A payload describing the pats and a bunch of --- GRHS. -data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(PmGRHSs p) } - --- | A guard tree denoting 'GRHSs': A bunch of 'PmLet' guards for local --- bindings from the 'GRHSs's @where@ clauses and the actual list of 'GRHS'. --- See Note [Long-distance information for HsLocalBinds] in --- "GHC.HsToCore.Pmc.Desugar". -data PmGRHSs p = PmGRHSs { pgs_lcls :: !p, pgs_grhss :: !(NonEmpty (PmGRHS p))} - --- | A guard tree denoting 'GRHS': A payload describing the grds and a 'SrcInfo' --- useful for printing out in warnings messages. -data PmGRHS p = PmGRHS { pg_grds :: !p, pg_rhs :: !SrcInfo } - --- | A guard tree denoting an -XEmptyCase. -newtype PmEmptyCase = PmEmptyCase { pe_var :: Id } - --- | A guard tree denoting a pattern binding. -newtype PmPatBind p = - -- just reuse GrdGRHS and pretend its @SrcInfo@ is info on the /pattern/, - -- rather than on the pattern bindings. - PmPatBind (PmGRHS p) - -instance Outputable SrcInfo where - ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss) - ppr (SrcInfo (L s _)) = ppr s - --- | Format LYG guards as @| True <- x, let x = 42, !z@ -instance Outputable GrdVec where - ppr (GrdVec []) = empty - ppr (GrdVec (g:gs)) = fsep (char '|' <+> ppr g : map ((comma <+>) . ppr) gs) - --- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as --- @{ ; ...; }@ -pprLygSequence :: Outputable a => NonEmpty a -> SDoc -pprLygSequence (NE.toList -> as) = - braces (space <> fsep (punctuate semi (map ppr as)) <> space) - -instance Outputable p => Outputable (PmMatchGroup p) where - ppr (PmMatchGroup matches) = pprLygSequence matches - -instance Outputable p => Outputable (PmMatch p) where - ppr (PmMatch { pm_pats = grds, pm_grhss = grhss }) = - ppr grds <+> ppr grhss - -instance Outputable p => Outputable (PmGRHSs p) where - ppr (PmGRHSs { pgs_lcls = _lcls, pgs_grhss = grhss }) = - ppr grhss - -instance Outputable p => Outputable (PmGRHS p) where - ppr (PmGRHS { pg_grds = grds, pg_rhs = rhs }) = - ppr grds <+> text "->" <+> ppr rhs - -instance Outputable p => Outputable (PmPatBind p) where - ppr (PmPatBind PmGRHS { pg_grds = grds, pg_rhs = bind }) = - ppr bind <+> ppr grds <+> text "=" <+> text "..." - -instance Outputable PmEmptyCase where - ppr (PmEmptyCase { pe_var = var }) = - text " ppr var <> text ">" - -data Precision = Approximate | Precise - deriving (Eq, Show) - -instance Outputable Precision where - ppr = text . show - -instance Semi.Semigroup Precision where - Precise <> Precise = Precise - _ <> _ = Approximate - -instance Monoid Precision where - mempty = Precise - mappend = (Semi.<>) - --- | Redundancy sets, used to determine redundancy of RHSs and bang patterns --- (later digested into a 'CIRB'). -data RedSets - = RedSets - { rs_cov :: !Nablas - -- ^ The /Covered/ set; the set of values reaching a particular program - -- point. - , rs_div :: !Nablas - -- ^ The /Diverging/ set; empty if no match can lead to divergence. - -- If it wasn't empty, we have to turn redundancy warnings into - -- inaccessibility warnings for any subclauses. - , rs_bangs :: !(OrdList (Nablas, SrcInfo)) - -- ^ If any of the 'Nablas' is empty, the corresponding 'SrcInfo' pin-points - -- a bang pattern in source that is redundant. See Note [Dead bang patterns]. - } - -instance Outputable RedSets where - ppr RedSets { rs_cov = _cov, rs_div = _div, rs_bangs = _bangs } - -- It's useful to change this definition for different verbosity levels in - -- printf-debugging - = empty - --- | Pattern-match coverage check result -data CheckResult a - = CheckResult - { cr_ret :: !a - -- ^ A hole for redundancy info and covered sets. - , cr_uncov :: !Nablas - -- ^ The set of uncovered values falling out at the bottom. - -- (for -Wincomplete-patterns, but also important state for the algorithm) - , cr_approx :: !Precision - -- ^ A flag saying whether we ran into the 'maxPmCheckModels' limit for the - -- purpose of suggesting to crank it up in the warning message. Writer state. - } deriving Functor - -instance Outputable a => Outputable (CheckResult a) where - ppr (CheckResult c unc pc) - = text "CheckResult" <+> ppr_precision pc <+> braces (fsep - [ field "ret" c <> comma - , field "uncov" unc]) - where - ppr_precision Precise = empty - ppr_precision Approximate = text "(Approximate)" - field name value = text name <+> equals <+> ppr value - --- --- * Pre and post coverage checking synonyms --- - --- | Used as tree payload pre-checking. The LYG guards to check. -type Pre = GrdVec - --- | Used as tree payload post-checking. The redundancy info we elaborated. -type Post = RedSets diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -30,10 +30,9 @@ tracePm :: String -> SDoc -> DsM () tracePm herald doc = do - dflags <- getDynFlags - logger <- getLogger + logger <- getLogger printer <- mkPrintUnqualifiedDs - liftIO $ dumpIfSet_dyn_printer printer logger dflags + liftIO $ putDumpFileMaybe' logger printer Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -34,6 +34,7 @@ import GHC.Driver.Session +import GHC.HsToCore.Errors.Types import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad @@ -330,15 +331,14 @@ } where no_splice (L loc _) - = notHandledL (locA loc) "Splices within declaration brackets" empty + = notHandledL (locA loc) ThSplicesWithinDeclBrackets no_default_decl (L loc decl) - = notHandledL (locA loc) "Default declarations" (ppr decl) + = notHandledL (locA loc) (ThDefaultDeclarations decl) no_warn :: LWarnDecl GhcRn -> MetaM a no_warn (L loc (Warning _ thing _)) - = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $ - text "Pragma for declaration of" <+> ppr thing + = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing) no_doc (L loc _) - = notHandledL (locA loc) "Haddock documentation" empty + = notHandledL (locA loc) ThHaddockDocumentation hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in quotes] @@ -530,9 +530,7 @@ ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc opts ksig' con' derivs1 } - (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:" - <+> pprQuotedList - (getConNames $ unLoc $ head cons)) + (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons)) (DataType, _) -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreListM conTyConName consL @@ -564,7 +562,7 @@ addTyClTyVarBinds resTyVar $ \_ -> case info of ClosedTypeFamily Nothing -> - notHandled "abstract closed type family" (ppr decl) + notHandled (ThAbstractClosedTypeFamily decl) ClosedTypeFamily (Just eqns) -> do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns ; eqns2 <- coreListM tySynEqnTyConName eqns1 @@ -755,7 +753,7 @@ return (locA loc, dec) where conv_cimportspec (CLabel cls) - = notHandled "Foreign label" (doubleQuotes (ppr cls)) + = notHandled (ThForeignLabel cls) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" conv_cimportspec (CFunction (StaticTarget _ fs _ True)) = return (unpackFS fs) @@ -770,7 +768,7 @@ chStr = case mch of Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " _ -> "" -repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl) +repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl) repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) repCCallConv CCallConv = rep2_nw cCallName [] @@ -997,8 +995,8 @@ rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc) -rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas +rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty (locA loc) @@ -1118,7 +1116,7 @@ repInline NoInline = dataCon noInlineDataConName repInline Inline = dataCon inlineDataConName repInline Inlinable = dataCon inlinableDataConName -repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty +repInline NoUserInlinePrag = notHandled ThNoUserInline repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName @@ -1416,7 +1414,7 @@ t' <- repLTy t repTImplicitParam n' t' -repTy ty = notHandled "Exotic form of type" (ppr ty) +repTy ty = notHandled (ThExoticFormOfType ty) repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i] @@ -1552,7 +1550,7 @@ wrapGenSyms ss e' } | otherwise - = notHandled "monad comprehension and [: :]" (ppr e) + = notHandled (ThMonadComprehensionSyntax e) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = @@ -1625,8 +1623,8 @@ then repE ds_expr else repE orig_expr } -repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled "Cost centres" (ppr e) -repE e = notHandled "Expression form" (ppr e) +repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) +repE e = notHandled (ThExpressionForm e) {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1717,7 +1715,7 @@ Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } - Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) + Ambiguous{} -> notHandled (ThAmbiguousRecordUpdates fld) @@ -1798,7 +1796,7 @@ ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } repSts [] = return ([],[]) -repSts other = notHandled "Exotic statement" (ppr other) +repSts other = notHandled (ThExoticStatement other) ----------------------------------------------------------- @@ -2016,7 +2014,7 @@ do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) +repLambda (L _ m) = notHandled (ThGuardedLambdas m) ----------------------------------------------------------------------------- @@ -2041,12 +2039,8 @@ repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p) = do { x' <- lookupNBinder x; p1 <- repLP p ; repPaspat x' p1 } -repP (ParPat _ _ p _) = repLP p -repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps) - ; e' <- repE e - ; repPview e' p} -repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps) +repP (ParPat _ _ p _) = repLP p +repP (ListPat _ ps) = do { qs <- repLPs ps; repPlist qs } repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } @@ -2072,12 +2066,12 @@ repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP p@(NPat _ _ (Just _) _) = notHandled (ThNegativeOverloadedPatterns p) repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice -repP other = notHandled "Exotic pattern" (ppr other) +repP other = notHandled (ThExoticPattern other) ---------------------------------------------------------- -- Declaration ordering helpers @@ -2683,7 +2677,7 @@ arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty'] - RecConGADT ips -> do + RecConGADT ips _ -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, @@ -2841,7 +2835,7 @@ lit_expr <- lift $ dsLit lit' case mb_lit_name of Just lit_name -> rep2_nw lit_name [lit_expr] - Nothing -> notHandled "Exotic literal" (ppr lit) + Nothing -> notHandled (ThExoticLiteral lit) where mb_lit_name = case lit of HsInteger _ _ _ -> Just integerLName @@ -3008,15 +3002,12 @@ coreVar id = MkC (Var id) ----------------- Failure ----------------------- -notHandledL :: SrcSpan -> String -> SDoc -> MetaM a -notHandledL loc what doc +notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a +notHandledL loc reason | isGoodSrcSpan loc - = mapReaderT (putSrcSpanDs loc) $ notHandled what doc + = mapReaderT (putSrcSpanDs loc) $ notHandled reason | otherwise - = notHandled what doc + = notHandled reason -notHandled :: String -> SDoc -> MetaM a -notHandled what doc = lift $ failWithDs msg - where - msg = hang (text what <+> text "not (yet) handled by Template Haskell") - 2 doc +notHandled :: ThRejectionReason -> MetaM a +notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason) diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -12,8 +12,6 @@ import GHC.Driver.Env import GHC.Driver.Session -import GHC.Platform -import GHC.Platform.Ways import GHC.Tc.Types @@ -23,29 +21,26 @@ import GHC.Utils.Panic import GHC.Types.Name -import GHC.Types.Name.Set +import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Unit import GHC.Unit.External -import GHC.Unit.State -import GHC.Unit.Finder import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps import GHC.Data.Maybe -import Control.Monad (filterM) -import Data.List (sortBy, sort, nub) -import Data.IORef +import Data.List (sortBy, sort, partition) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set -import System.Directory -import System.FilePath +import GHC.Linker.Types +import GHC.Linker.Loader ( getLoaderState ) +import GHC.Types.SourceFile {- Note [Module self-dependency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -73,15 +68,15 @@ mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules (TcGblEnv{ tcg_mod = mod, - tcg_imports = imports, - tcg_th_used = th_var + tcg_imports = imports }) = do - -- Template Haskell used? - let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] - plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms) - th_used <- readIORef th_var - let direct_mods = modDepsElts (delFromUFM (imp_direct_dep_mods imports) (moduleName mod)) + + let (home_plugins, package_plugins) = partition ((== iuid) . toUnitId . moduleUnit) pluginModules + plugin_dep_pkgs = map (toUnitId . moduleUnit) package_plugins + all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot)) (imp_direct_dep_mods imports) (map moduleName home_plugins) + + direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -95,9 +90,7 @@ direct_pkgs_0 = foldr Set.insert (imp_dep_direct_pkgs imports) plugin_dep_pkgs - direct_pkgs - | th_used = Set.insert thUnitId direct_pkgs_0 - | otherwise = direct_pkgs_0 + direct_pkgs = direct_pkgs_0 -- Set the packages required to be Safe according to Safe Haskell. -- See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -116,7 +109,6 @@ dep_trusted_pkgs = sort (Set.toList trust_pkgs), dep_boot_mods = sort source_mods, dep_orphs = dep_orphs, - dep_plgins = dep_plgins, dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } -- sort to get into canonical order -- NB. remember to use lexicographic ordering @@ -124,25 +116,26 @@ mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] - -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged - pluginModules +mkUsageInfo :: HscEnv -> Module -> HscSource -> ImportedMods -> NameSet -> [FilePath] + -> [(Module, Fingerprint)] -> IO [Usage] +mkUsageInfo hsc_env this_mod src dir_imp_mods used_names dependent_files merged = do eps <- hscEPS hsc_env hashes <- mapM getFileHash dependent_files - plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules + -- Dependencies on object files due to TH and plugins + object_usages <- mkObjectUsage (eps_PIT eps) hsc_env (GWIB (moduleName this_mod) (hscSourceToIsBoot src)) let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names usages = mod_usages ++ [ UsageFile { usg_file_path = f - , usg_file_hash = hash } + , usg_file_hash = hash + , usg_file_label = Nothing } | (f, hash) <- zip dependent_files hashes ] ++ [ UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } | (mod, hash) <- merged ] - ++ concat plugin_usages + ++ object_usages usages `seqList` return usages -- seq the list of Usages returned: occasionally these -- don't get evaluated for a while and we can end up hanging on to @@ -185,85 +178,47 @@ compare implementation hashes for recompilation. Creation of implementation hashes is however potentially expensive. -} -mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] -mkPluginUsage hsc_env pluginModule - = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of - LookupFound _ pkg -> do - -- The plugin is from an external package: - -- search for the library files containing the plugin. - let searchPaths = collectLibraryDirs (ways dflags) [pkg] - useDyn = WayDyn `elem` ways dflags - suffix = if useDyn then platformSOExt platform else "a" - libLocs = [ searchPath "lib" ++ libLoc <.> suffix - | searchPath <- searchPaths - , libLoc <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg - ] - -- we also try to find plugin library files by adding WayDyn way, - -- if it isn't already present (see trac #15492) - paths = - if useDyn - then libLocs - else - let dflags' = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) } - dlibLocs = [ searchPath platformHsSOName platform dlibLoc - | searchPath <- searchPaths - , dlibLoc <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg - ] - in libLocs ++ dlibLocs - files <- filterM doesFileExist paths - case files of - [] -> - pprPanic - ( "mkPluginUsage: missing plugin library, tried:\n" - ++ unlines paths - ) - (ppr pNm) - _ -> mapM hashFile (nub files) - _ -> do - let fc = hsc_FC hsc_env - let units = hsc_units hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - foundM <- findPluginModule fc units home_unit dflags pNm - case foundM of - -- The plugin was built locally: look up the object file containing - -- the `plugin` binder, and all object files belong to modules that are - -- transitive dependencies of the plugin that belong to the same package. - Found ml _ -> do - pluginObject <- hashFile (ml_obj_file ml) - depObjects <- catMaybes <$> mapM lookupObjectFile deps - return (nub (pluginObject : depObjects)) - _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm) + +-- | Find object files corresponding to the transitive closure of given home +-- modules and direct object files for pkg dependencies +mkObjectUsage :: PackageIfaceTable -> HscEnv -> ModuleNameWithIsBoot -> IO [Usage] +mkObjectUsage pit hsc_env mnwib = do + case hsc_interp hsc_env of + Just interp -> do + mps <- getLoaderState interp + case mps of + Just ps -> do + let ls = fromMaybe [] $ Map.lookup mnwib (module_deps ps) + ds = hs_objs_loaded ps + concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds) + Nothing -> return [] + Nothing -> return [] + + where - dflags = hsc_dflags hsc_env - fc = hsc_FC hsc_env - home_unit = hsc_home_unit hsc_env - units = hsc_units hsc_env - platform = targetPlatform dflags - pkgs = hsc_units hsc_env - pNm = moduleName $ mi_module pluginModule - pPkg = moduleUnit $ mi_module pluginModule - deps = map gwib_mod $ - dep_direct_mods $ mi_deps pluginModule + linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls - -- Lookup object file for a plugin dependency, - -- from the same package as the plugin. - lookupObjectFile nm = do - foundM <- findImportedModule fc units home_unit dflags nm Nothing - case foundM of - Found ml m - | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml) - | otherwise -> return Nothing - _ -> pprPanic "mkPluginUsage: no object for dependency" - (ppr pNm <+> ppr nm) + msg m = moduleNameString (moduleName m) ++ "[TH] changed" - hashFile f = do - fExist <- doesFileExist f - if fExist - then do - h <- getFileHash f - return (UsageFile f h) - else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) + fing mmsg fn = UsageFile fn <$> getFileHash fn <*> pure mmsg + + unlinkedToUsage m ul = + case nameOfObject_maybe ul of + Just fn -> fing (Just (msg m)) fn + Nothing -> do + -- This should only happen for home package things but oneshot puts + -- home package ifaces in the PIT. + let miface = lookupIfaceByModule (hsc_HPT hsc_env) pit m + case miface of + Nothing -> pprPanic "mkObjectUsage" (ppr m) + Just iface -> + return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface)) + + librarySpecToUsage :: LibrarySpec -> IO [Usage] + librarySpecToUsage (Objects os) = traverse (fing Nothing) os + librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn] + librarySpecToUsage (DLLPath fn) = traverse (fing Nothing) [fn] + librarySpecToUsage _ = return [] mk_mod_usage_info :: PackageIfaceTable -> HscEnv diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -51,7 +51,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) import GHC.Hs -import GHC.Tc.Utils.Zonk +import GHC.Hs.Syn.Type import GHC.Tc.Utils.TcType( tcSplitTyConApp ) import GHC.Core import GHC.HsToCore.Monad @@ -405,11 +405,10 @@ mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs dflags <- getDynFlags - let - full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkLitString full_msg) - -- mkLitString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) + let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) + fail_expr = mkRuntimeErrorApp err_id unitTy full_msg + return $ mkWildCase fail_expr (unrestricted unitTy) ty [] + -- See Note [Incompleteness and linearity] {- Note [Incompleteness and linearity] @@ -426,15 +425,15 @@ Instead, we use 'f x False = case error "Non-exhausive pattern..." :: () of {}'. This case expression accounts for linear variables by assigning bottom usage (See Note [Bottom as a usage] in GHC.Core.Multiplicity). -This is done in mkFailExpr. +This is done in mkErrorAppDs, called from mkFailExpr. We use '()' instead of the original return type ('a' in this case) -because there might be levity polymorphism, e.g. in +because there might be representation polymorphism, e.g. in g :: forall (a :: TYPE r). (() -> a) %1 -> Bool -> a g x True = x () adding 'g x False = case error "Non-exhaustive pattern" :: a of {}' -would create an illegal levity-polymorphic case binder. +would create an illegal representation-polymorphic case binder. This is important for pattern synonym matchers, which often look like this 'g'. Similarly, a hole @@ -458,9 +457,7 @@ mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr mkFailExpr ctxt ty - = do fail_expr <- mkErrorAppDs pAT_ERROR_ID unitTy (matchContextErrString ctxt) - return $ mkWildCase fail_expr (unrestricted unitTy) ty [] - -- See Note [Incompleteness and linearity] + = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) {- 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. @@ -529,14 +526,14 @@ 3. (as described in #2409) - The isLocalId ensures that we don't turn + The isInternalName ensures that we don't turn True `seq` e into case True of True { ... } which stupidly tries to bind the datacon 'True'. -} --- NB: Make sure the argument is not levity polymorphic +-- NB: Make sure the argument is not representation-polymorphic mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) @@ -556,7 +553,7 @@ mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make --- NB: No argument can be levity polymorphic +-- NB: No argument can be representation-polymorphic mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -13,6 +13,7 @@ -- * Public API for interface file serialisation writeBinIface, readBinIface, + readBinIfaceHeader, getSymtabName, getDictFastString, CheckHiWay(..), @@ -49,6 +50,7 @@ import GHC.Platform import GHC.Data.FastString import GHC.Settings.Constants +import GHC.Utils.Fingerprint import Data.Array import Data.Array.IO @@ -69,15 +71,17 @@ = TraceBinIFace (SDoc -> IO ()) | QuietBinIFace --- | Read an interface file. -readBinIface +-- | Read an interface file header, checking the magic number, version, and +-- way. Returns the hash of the source file and a BinHandle which points at the +-- start of the rest of the interface file data. +readBinIfaceHeader :: Profile -> NameCache -> CheckHiWay -> TraceBinIFace -> FilePath - -> IO ModIface -readBinIface profile name_cache checkHiWay traceBinIFace hi_path = do + -> IO (Fingerprint, BinHandle) +readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do let platform = profilePlatform profile wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () @@ -118,6 +122,20 @@ when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file profile tag" tag check_tag + src_hash <- get bh + pure (src_hash, bh) + +-- | Read an interface file. +readBinIface + :: Profile + -> NameCache + -> CheckHiWay + -> TraceBinIFace + -> FilePath + -> IO ModIface +readBinIface profile name_cache checkHiWay traceBinIface hi_path = do + (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path + extFields_p <- get bh mod_iface <- getWithUserData name_cache bh @@ -125,8 +143,10 @@ seekBin bh extFields_p extFields <- get bh - return mod_iface{mi_ext_fields = extFields} - + return mod_iface + { mi_ext_fields = extFields + , mi_src_hash = src_hash + } -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any @@ -166,10 +186,11 @@ let platform = profilePlatform profile put_ bh (binaryInterfaceMagic platform) - -- The version and profile tag go next + -- The version, profile tag, and source hash go next put_ bh (show hiVersion) let tag = profileBuildTag profile put_ bh tag + put_ bh (mi_src_hash mod_iface) extFields_p_p <- tellBin bh put_ bh extFields_p_p 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,10 +270,10 @@ ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } -trace_if :: Logger -> DynFlags -> SDoc -> IO () +trace_if :: Logger -> SDoc -> IO () {-# INLINE trace_if #-} -trace_if logger dflags doc = when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags doc +trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc -trace_hi_diffs :: Logger -> DynFlags -> SDoc -> IO () +trace_hi_diffs :: Logger -> SDoc -> IO () {-# INLINE trace_hi_diffs #-} -trace_hi_diffs logger dflags doc = when (dopt Opt_D_dump_hi_diffs dflags) $ putMsg logger dflags doc +trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -24,7 +24,6 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder.Types -import GHC.Unit.State import GHC.Utils.Outputable as Outputable diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -30,24 +30,21 @@ import GHC.Types.Basic import GHC.Data.BooleanFormula import GHC.Core.Class ( className, classSCSelIds ) -import GHC.Core.Utils ( exprType ) -import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) +import GHC.Core.ConLike ( conLikeName ) import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.FVs import GHC.Core.DataCon ( dataConNonlinearType ) import GHC.Types.FieldLabel import GHC.Hs -import GHC.Driver.Env -import GHC.Utils.Monad ( concatMapM, liftIO ) +import GHC.Hs.Syn.Type +import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) ) import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc -import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) -import GHC.Core.Type ( mkVisFunTys, Type ) +import GHC.Core.Type ( Type ) import GHC.Core.Predicate import GHC.Core.InstEnv -import GHC.Builtin.Types ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) @@ -72,14 +69,13 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Data ( Data, Typeable ) +import Data.Functor.Identity ( Identity(..) ) import Data.Void ( Void, absurd ) import Control.Monad ( forM_ ) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class ( lift ) -import GHC.HsToCore.Types -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad +import Control.Applicative ( (<|>) ) {- Note [Updating HieAst for changes in the GHC AST] @@ -277,16 +273,17 @@ = addSubstitution mono poly . f go _ f = f -type HieM = ReaderT NodeOrigin (StateT HieState DsM) +type HieM = ReaderT NodeOrigin (State HieState) -- | Construct an 'HieFile' from the outputs of the typechecker. -mkHieFile :: ModSummary +mkHieFile :: MonadIO m + => ModSummary -> TcGblEnv - -> RenamedSource -> Hsc HieFile + -> RenamedSource -> m HieFile mkHieFile ms ts rs = do let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) src <- liftIO $ BS.readFile src_file - mkHieFileWithSource src_file src ms ts rs + pure $ mkHieFileWithSource src_file src ms ts rs -- | Construct an 'HieFile' from the outputs of the typechecker but don't -- read the source file again from disk. @@ -294,16 +291,14 @@ -> BS.ByteString -> ModSummary -> TcGblEnv - -> RenamedSource -> Hsc HieFile -mkHieFileWithSource src_file src ms ts rs = do + -> RenamedSource -> HieFile +mkHieFileWithSource src_file src ms ts rs = let tc_binds = tcg_binds ts top_ev_binds = tcg_ev_binds ts insts = tcg_insts ts tcs = tcg_tcs ts - hsc_env <- Hsc $ \e w -> return (e, w) - (_msgs, res) <- liftIO $ initDs hsc_env ts $ getCompressedAsts tc_binds rs top_ev_binds insts tcs - let (asts',arr) = expectJust "mkHieFileWithSource" res - return $ HieFile + (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in + HieFile { hie_hs_file = src_file , hie_module = ms_mod ms , hie_types = arr @@ -314,15 +309,15 @@ } getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] - -> DsM (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) -getCompressedAsts ts rs top_ev_binds insts tcs = do - asts <- enrichHie ts rs top_ev_binds insts tcs - return $ compressTypes asts + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs top_ev_binds insts tcs = + let asts = enrichHie ts rs top_ev_binds insts tcs in + compressTypes asts enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] - -> DsM (HieASTs Type) + -> HieASTs Type enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = - flip evalStateT initState $ flip runReaderT SourceInfo $ do + runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts rasts <- processGrp hsGrp imps <- toHie $ filter (not . ideclImplicit . unLoc) imports @@ -713,71 +708,75 @@ -- the expression. It is not yet possible to do this efficiently for all -- expression forms, so we skip filling in the type for those inputs. -- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. --- --- See #16233 +-- See Note [Computing the type of every node in the tree] instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where - getTypeNode e@(L spn e') = + getTypeNode (L spn e) = case hiePass @p of - HieRn -> makeNodeA e' spn - HieTc -> - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsUnboundVar (HER _ ty _) _ -> Just ty - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) + HieRn -> fallback + HieTc -> case computeType e of + Just ty -> makeTypeNodeA e spn ty + Nothing -> fallback + where + fallback :: HieM [HieAST Type] + fallback = makeNodeA e spn - XExpr (ConLikeTc (RealDataCon con) _ _) -> Just (dataConNonlinearType con) + -- | Skip computing the type of some expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before skipping more kinds of expressions. See impact on Haddock + -- performance before computing the types of more expressions. + -- + -- See Note [Computing the type of every node in the tree] + computeType :: HsExpr GhcTc -> Maybe Type + computeType e = case e of + HsApp{} -> Nothing + HsAppType{} -> Nothing + NegApp{} -> Nothing + HsPar _ _ e _ -> computeLType e + ExplicitTuple{} -> Nothing + HsIf _ _ t f -> computeLType t <|> computeLType f + HsLet _ _ body -> computeLType body + RecordCon con_expr _ _ -> computeType con_expr + ExprWithTySig _ e _ -> computeLType e + HsStatic _ e -> computeLType e + HsTick _ _ e -> computeLType e + HsBinTick _ _ _ e -> computeLType e + HsPragE _ _ e -> computeLType e + XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e + e -> Just (hsExprType e) - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + computeLType :: LHsExpr GhcTc -> Maybe Type + computeLType (L _ e) = computeType e - ExplicitList ty _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty +{- Note [Computing the type of every node in the tree] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Iface.Ext.Ast we decorate every node in the AST with its +type, computed by `hsExprType` applied to that node. So it's +important that `hsExprType` takes roughly constant time per node. +There are three cases to consider: - _ -> Nothing +1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their + type -- e.g. it is stored in the node, or in sub-node thereof. - in - case tyOpt of - Just t -> makeTypeNodeA e' spn t - Nothing - | skipDesugaring e' -> fallback - | otherwise -> do - (e, no_errs) <- lift $ lift $ discardWarningsDs $ askNoErrsDs $ dsLExpr e - if no_errs - then makeTypeNodeA e' spn . exprType $ e - else fallback - where - fallback = makeNodeA e' spn +2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is + the type of a child, so we can recurse, fast. We don't expect the + nesting to be very deep, so while this is theoretically non-linear, + we don't expect it to be a problem in practice. - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkVisFunTys args res +3. A very few nodes (e.g. HsApp) are more troublesome because we need to + take the type of a child, and then do some non-trivial processing. + To be conservative on computation, we decline to decorate these + nodes, using `fallback` instead. - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr GhcTc -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsRecSel{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - XExpr (WrapExpr {}) -> False - _ -> True +The function `computeType e` returns `Just t` if we can find the type +of `e` cheaply, and `Nothing` otherwise. The base `Nothing` cases +are the troublesome ones in (3) above. Hopefully we can ultimately +get rid of them all. +See #16233 + +-} + data HiePassEv p where HieRn :: HiePassEv 'Renamed HieTc :: HiePassEv 'Typechecked @@ -1021,14 +1020,14 @@ ] XPat e -> case hiePass @p of - HieTc -> - let CoPat wrap pat _ = e - in [ toHie $ L ospan wrap - , toHie $ PS rsp scope pscope $ (L ospan pat) - ] -#if __GLASGOW_HASKELL__ < 811 - HieRn -> [] -#endif + HieRn -> case e of + HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] + HieTc -> case e of + CoPat wrap pat _ -> + [ toHie $ L ospan wrap + , toHie $ PS rsp scope pscope $ (L ospan pat) + ] + ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] where contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a) -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) @@ -1390,7 +1389,7 @@ instance ToHie (HsConDeclGADTDetails GhcRn) where toHie (PrefixConGADT args) = toHie args - toHie (RecConGADT rec) = toHie rec + toHie (RecConGADT rec _) = toHie rec instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where toHie (L span top) = concatM $ makeNode top span : case top of @@ -1623,7 +1622,7 @@ ctxScope = maybe NoScope mkLScopeA ctx argsScope = case args of PrefixConGADT xs -> scaled_args_scope xs - RecConGADT x -> mkLScopeA x + RecConGADT x _ -> mkLScopeA x tyScope = mkLScopeA typ resScope = ResolvedScopes [ctxScope, rhsScope] ConDeclH98 { con_name = name, con_ex_tvs = qvars diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -40,7 +40,7 @@ import Data.List (find) import Data.Traversable ( for ) import Data.Coerce -import Control.Monad.Trans.State.Strict hiding (get) +import GHC.Utils.Monad.State.Strict hiding (get) import Control.Monad.Trans.Reader import qualified Data.Tree as Tree @@ -187,7 +187,7 @@ freshTypeIndex :: State HieTypeState TypeIndex freshTypeIndex = do index <- gets freshIndex - modify' $ \hts -> hts { freshIndex = index+1 } + modify $ \hts -> hts { freshIndex = index+1 } return index compressTypes @@ -217,7 +217,7 @@ where extendHTS t ht = do i <- freshTypeIndex - modify' $ \(HTS tm tt fi) -> + modify $ \(HTS tm tt fi) -> HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi return i 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 @@ -37,6 +37,8 @@ import GHC.Prelude +import GHC.Platform.Profile + import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches ) @@ -45,7 +47,6 @@ import GHC.Driver.Errors.Types import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -56,6 +57,7 @@ import GHC.Iface.Env import GHC.Iface.Errors as Iface_Errors +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Utils.Binary ( BinData(..) ) @@ -65,6 +67,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger +import GHC.Utils.Trace import GHC.Settings.Constants @@ -165,9 +168,8 @@ -- It's not a wired-in thing -- the caller caught that importDecl name = assert (not (isWiredInName name)) $ - do { dflags <- getDynFlags - ; logger <- getLogger - ; liftIO $ trace_if logger dflags nd_doc + do { logger <- getLogger + ; liftIO $ trace_if logger nd_doc -- Load the interface, which should populate the PTE ; mb_iface <- assertPpr (isExternalName name) (ppr name) $ @@ -241,9 +243,8 @@ = return () | otherwise = do { mod <- getModule - ; dflags <- getDynFlags ; logger <- getLogger - ; liftIO $ trace_if logger dflags (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) + ; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) ; assert (isExternalName tc_name ) when (mod /= nameModule tc_name) (initIfaceTcRn (loadWiredInHomeIface tc_name)) @@ -298,7 +299,7 @@ loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc err + Failed err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Succeeded iface -> return iface } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. @@ -414,7 +415,8 @@ loadInterfaceWithException doc mod_name where_from = do dflags <- getDynFlags - withException dflags (loadInterface doc mod_name where_from) + let ctx = initSDocContext dflags defaultUserStyle + withException ctx (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom @@ -442,15 +444,12 @@ | otherwise = do logger <- getLogger - dflags <- getDynFlags - withTimingSilent logger dflags (text "loading interface") (pure ()) $ do + withTimingSilent logger (text "loading interface") (pure ()) $ do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv - ; dflags <- getDynFlags - ; logger <- getLogger - ; liftIO $ trace_if logger dflags (text "Considering whether to load" <+> ppr mod <+> ppr from) + ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already ; hsc_env <- getTopEnv @@ -728,10 +727,9 @@ | otherwise = case getModuleInstantiation mod of (imod, Just indef) -> do - dflags <- getDynFlags logger <- getLogger let insts = instUnitInsts (moduleUnit indef) - liftIO $ trace_if logger dflags (text "Considering whether to load" <+> ppr mod <+> + liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") (eps, hpt) <- getEpsAndHpt case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of @@ -863,7 +861,7 @@ findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags - trace_if logger dflags (sep [hsep [text "Reading", + trace_if logger (sep [hsep [text "Reading", if hi_boot_file == IsBoot then text "[boot]" else Outputable.empty, @@ -902,7 +900,7 @@ hi_boot_file iface fp return r err -> do - trace_if logger dflags (text "...not found") + trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state home_unit @@ -931,15 +929,15 @@ | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> return () | otherwise -> - do trace_if logger dflags (text "Dynamic hash doesn't match") + do trace_if logger (text "Dynamic hash doesn't match") setDynamicTooFailed dflags Failed err -> - do trace_if logger dflags (text "Failed to load dynamic interface file:" $$ err) + do trace_if logger (text "Failed to load dynamic interface file:" $$ err) setDynamicTooFailed dflags read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do - trace_if logger dflags (text "readIFace" <+> text file_path) + trace_if logger (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -958,11 +956,10 @@ -- | Write interface file -writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO () -writeIface logger dflags hi_file_path new_iface +writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO () +writeIface logger profile hi_file_path new_iface = do createDirectoryIfMissing True (takeDirectory hi_file_path) - let printer = TraceBinIFace (debugTraceMsg logger dflags 3) - profile = targetProfile dflags + let printer = TraceBinIFace (debugTraceMsg logger 3) writeBinIface profile printer hi_file_path new_iface -- | @readIface@ tries just the one file. @@ -1063,7 +1060,7 @@ showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO () showIface logger dflags unit_state name_cache filename = do let profile = targetProfile dflags - printer = putLogMsg logger dflags MCOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. @@ -1076,7 +1073,7 @@ print_unqual = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages - putLogMsg logger dflags MCDump noSrcSpan + logMsg logger MCDump noSrcSpan $ withPprStyle (mkDumpStyle print_unqual) $ pprModIface unit_state iface @@ -1107,6 +1104,7 @@ , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) + , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface)) , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (text "where") @@ -1168,6 +1166,8 @@ ppr (usg_file_hash usage)] pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] +pprUsage usage@UsageHomeModuleInterface{} + = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' @@ -1185,14 +1185,13 @@ , dep_direct_pkgs = pkgs , dep_trusted_pkgs = tps , dep_finsts = finsts - , dep_plgins = plugins }) + }) = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> fsep (map ppr_mod dmods), text "boot module dependencies:" <+> fsep (map ppr bmods), text "direct package dependencies:" <+> fsep (map ppr_pkg pkgs), if null tps then empty else text "trusted package dependencies:" <+> fsep (map ppr_pkg pkgs), text "orphans:" <+> fsep (map ppr orphs), - text "plugins:" <+> fsep (map ppr plugins), text "family instance modules:" <+> fsep (map ppr finsts) ] where diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -51,7 +51,6 @@ import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Driver.Plugins (LoadedPlugin(..)) import GHC.Types.Id @@ -77,6 +76,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc hiding ( eqListBy ) import GHC.Utils.Logger +import GHC.Utils.Trace import GHC.Data.FastString import GHC.Data.Maybe @@ -89,6 +89,7 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps import Data.Function @@ -96,6 +97,7 @@ import Data.Ord import Data.IORef + {- ************************************************************************ * * @@ -106,9 +108,10 @@ mkPartialIface :: HscEnv -> ModDetails + -> ModSummary -> ModGuts -> PartialModIface -mkPartialIface hsc_env mod_details +mkPartialIface hsc_env mod_details mod_summary ModGuts{ mg_module = this_mod , mg_hsc_src = hsc_src , mg_usages = usages @@ -125,7 +128,7 @@ , mg_arg_docs = arg_docs } = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages doc_hdr decl_docs arg_docs mod_details + safe_mode usages doc_hdr decl_docs arg_docs mod_summary mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information. @@ -147,7 +150,7 @@ -- Debug printing let unit_state = hsc_units hsc_env - dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText + putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface unit_state full_iface) return full_iface @@ -177,9 +180,10 @@ mkIfaceTc :: HscEnv -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably + -> ModSummary -> TcGblEnv -- Usages, deprecations, etc -> IO ModIface -mkIfaceTc hsc_env safe_mode mod_details +mkIfaceTc hsc_env safe_mode mod_details mod_summary tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -196,7 +200,8 @@ let pluginModules = map lpModule (hsc_plugins hsc_env) let home_unit = hsc_home_unit hsc_env deps <- mkDependencies (homeUnitId home_unit) - (map mi_module pluginModules) tc_result + (map mi_module pluginModules) + tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files) @@ -207,8 +212,8 @@ -- but if you pass that in here, we'll decide it's the local -- module and does not need to be recorded as a dependency. -- See Note [Identity versus semantic module] - usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names - dep_files merged pluginModules + usages <- mkUsageInfo hsc_env this_mod hsc_src (imp_mods imports) used_names + dep_files merged (doc_hdr', doc_map, arg_map) <- extractDocs tc_result @@ -217,7 +222,7 @@ used_th deps rdr_env fix_env warns hpc_info (imp_trust_own_pkg imports) safe_mode usages - doc_hdr' doc_map arg_map + doc_hdr' doc_map arg_map mod_summary mod_details mkFullIface hsc_env partial_iface Nothing @@ -231,12 +236,13 @@ -> Maybe HsDocString -> DeclDocMap -> ArgDocMap + -> ModSummary -> ModDetails -> PartialModIface mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages - doc_hdr decl_docs arg_docs + doc_hdr decl_docs arg_docs mod_summary ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -313,7 +319,9 @@ mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, mi_final_exts = (), - mi_ext_fields = emptyExtensibleFields } + mi_ext_fields = emptyExtensibleFields, + mi_src_hash = ms_hs_hash mod_summary + } where cmp_rule = lexicalCompareFS `on` ifRuleName -- Compare these lexicographically by OccName, *not* by unique, diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} -- | Module for detecting if recompilation is required module GHC.Iface.Recomp @@ -41,6 +42,7 @@ import GHC.Utils.Exception import GHC.Utils.Logger import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Trace import GHC.Types.Annotations import GHC.Types.Name @@ -49,7 +51,6 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env -import GHC.Types.SourceFile import GHC.Unit.External import GHC.Unit.Finder @@ -66,10 +67,14 @@ import Data.List (sortBy, sort) import qualified Data.Map as Map import Data.Word (Word64) +import Data.Either --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> import qualified Data.Semigroup +import GHC.List (uncons) +import Data.Ord +import Data.Containers.ListUtils {- ----------------------------------------------- @@ -107,11 +112,11 @@ = UpToDate -- ^ everything is up to date, recompilation is not required | MustCompile - -- ^ The .hs file has been touched, or the .o/.hi file does not exist + -- ^ The .hs file has been modified, or the .o/.hi file does not exist | RecompBecause String -- ^ The .o/.hi files are up to date, but something else has changed -- to force recompilation; the String says what (one-line summary) - deriving Eq + deriving (Eq, Show) instance Semigroup RecompileRequired where UpToDate <> r = r @@ -133,34 +138,32 @@ checkOldIface :: HscEnv -> ModSummary - -> SourceModified -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (RecompileRequired, Maybe ModIface) -checkOldIface hsc_env mod_summary source_modified maybe_iface +checkOldIface hsc_env mod_summary maybe_iface = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - showPass logger dflags $ + showPass logger $ "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) ++ " (use -ddump-hi-diffs for more details)" initIfaceCheck (text "checkOldIface") hsc_env $ - check_old_iface hsc_env mod_summary source_modified maybe_iface + check_old_iface hsc_env mod_summary maybe_iface check_old_iface :: HscEnv -> ModSummary - -> SourceModified -> Maybe ModIface -> IfG (RecompileRequired, Maybe ModIface) -check_old_iface hsc_env mod_summary src_modified maybe_iface +check_old_iface hsc_env mod_summary maybe_iface = let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env getIface = case maybe_iface of Just _ -> do - trace_if logger dflags (text "We already have the old interface for" <+> + trace_if logger (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) return maybe_iface Nothing -> loadIface @@ -171,20 +174,19 @@ read_result <- readIface dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do - trace_if logger dflags (text "FYI: cannot read old interface file:" $$ nest 4 err) - trace_hi_diffs logger dflags (text "Old interface file was invalid:" $$ nest 4 err) + trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err) + trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err) return Nothing Succeeded iface -> do - trace_if logger dflags (text "Read the interface file" <+> text iface_path) + trace_if logger (text "Read the interface file" <+> text iface_path) return $ Just iface src_changed | gopt Opt_ForceRecomp dflags = True - | SourceModified <- src_modified = True | otherwise = False in do when src_changed $ - liftIO $ trace_hi_diffs logger dflags (nest 4 $ text "Source file changed or recompilation check turned off") + liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off") case src_changed of -- If the source has changed and we're in interactive mode, @@ -209,31 +211,8 @@ -- even in the SourceUnmodifiedAndStable case we -- should check versions because some packages -- might have changed or gone away. - Just iface -> do - (recomp_reqd, mb_checked_iface) <- - checkVersions hsc_env mod_summary iface - return $ case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (#481) and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - let stable = case src_modified of - SourceUnmodifiedAndStable -> True - _ -> False - in if mi_used_th iface && not stable - then (RecompBecause "TH", mb_checked_iface) - else (recomp_reqd, mb_checked_iface) - _ -> (recomp_reqd, mb_checked_iface) + Just iface -> + checkVersions hsc_env mod_summary iface -- | Check if a module is still the same 'version'. -- @@ -251,7 +230,7 @@ -> ModIface -- Old interface -> IfG (RecompileRequired, Maybe ModIface) checkVersions hsc_env mod_summary iface - = do { liftIO $ trace_hi_diffs logger dflags + = do { liftIO $ trace_hi_diffs logger (text "Considering whether compilation is required for" <+> ppr (mi_module iface) <> colon) @@ -259,6 +238,8 @@ -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04! ; hsc_env <- getTopEnv + ; if mi_src_hash iface /= ms_hs_hash mod_summary + then return (RecompBecause "Source file changed", Nothing) else do { ; if not (isHomeModule home_unit (mi_module iface)) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- liftIO $ checkFlagHash hsc_env iface @@ -269,7 +250,7 @@ ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- liftIO $ checkMergedSignatures hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- liftIO $ checkHsig logger home_unit dflags mod_summary iface + ; recomp <- liftIO $ checkHsig logger home_unit mod_summary iface ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- pure (checkHie dflags mod_summary) ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -292,10 +273,10 @@ when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { ; updateEps_ $ \eps -> eps { eps_is_boot = mkModDeps $ (dep_boot_mods (mi_deps iface)) } } - ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u + ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u | u <- mi_usages iface] ; return (recomp, Just iface) - }}}}}}}}}} + }}}}}}}}}}} where logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env @@ -376,74 +357,70 @@ -- | Check if an hsig file needs recompilation because its -- implementing module has changed. -checkHsig :: Logger -> HomeUnit -> DynFlags -> ModSummary -> ModIface -> IO RecompileRequired -checkHsig logger home_unit dflags mod_summary iface = do +checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired +checkHsig logger home_unit mod_summary iface = do let outer_mod = ms_mod mod_summary inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) massert (isHomeModule home_unit outer_mod) case inner_mod == mi_semantic_module iface of - True -> up_to_date logger dflags (text "implementing module unchanged") + True -> up_to_date logger (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") -- | Check if @.hie@ file is out of date or missing. checkHie :: DynFlags -> ModSummary -> RecompileRequired checkHie dflags mod_summary = let hie_date_opt = ms_hie_date mod_summary - hs_date = ms_hs_date mod_summary + hi_date = ms_iface_date mod_summary in if not (gopt Opt_WriteHie dflags) then UpToDate - else case hie_date_opt of - Nothing -> RecompBecause "HIE file is missing" - Just hie_date - | hie_date < hs_date + else case (hie_date_opt, hi_date) of + (Nothing, _) -> RecompBecause "HIE file is missing" + (Just hie_date, Just hi_date) + | hie_date < hi_date -> RecompBecause "HIE file is out of date" - | otherwise - -> UpToDate + _ -> UpToDate -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired checkFlagHash hsc_env iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let old_hash = mi_flag_hash (mi_final_exts iface) new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally case old_hash == new_hash of - True -> up_to_date logger dflags (text "Module flags unchanged") - False -> out_of_date_hash logger dflags "flags changed" + True -> up_to_date logger (text "Module flags unchanged") + False -> out_of_date_hash logger "flags changed" (text " Module flags have changed") old_hash new_hash -- | Check the optimisation flags haven't changed checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired checkOptimHash hsc_env iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let old_hash = mi_opt_hash (mi_final_exts iface) new_hash <- fingerprintOptFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash - -> up_to_date logger dflags (text "Optimisation flags unchanged") + -> up_to_date logger (text "Optimisation flags unchanged") | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) - -> up_to_date logger dflags (text "Optimisation flags changed; ignoring") + -> up_to_date logger (text "Optimisation flags changed; ignoring") | otherwise - -> out_of_date_hash logger dflags "Optimisation flags changed" + -> out_of_date_hash logger "Optimisation flags changed" (text " Optimisation flags have changed") old_hash new_hash -- | Check the HPC flags haven't changed checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired checkHpcHash hsc_env iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let old_hash = mi_hpc_hash (mi_final_exts iface) new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash - -> up_to_date logger dflags (text "HPC flags unchanged") + -> up_to_date logger (text "HPC flags unchanged") | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) - -> up_to_date logger dflags (text "HPC flags changed; ignoring") + -> up_to_date logger (text "HPC flags changed; ignoring") | otherwise - -> out_of_date_hash logger dflags "HPC flags changed" + -> out_of_date_hash logger "HPC flags changed" (text " HPC flags have changed") old_hash new_hash @@ -451,7 +428,6 @@ -- If the -unit-id flags change, this can change too. checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired checkMergedSignatures hsc_env mod_summary iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_state = hsc_units hsc_env let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] @@ -460,7 +436,7 @@ Nothing -> [] Just r -> sort $ map (instModuleToModule unit_state) r if old_merged == new_merged - then up_to_date logger dflags (text "signatures to merge in unchanged" $$ ppr new_merged) + then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) else return (RecompBecause "signatures to merge in changed") -- If the direct imports of this module are resolved to targets that @@ -475,42 +451,72 @@ -- Returns (RecompBecause ) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface - = liftIO $ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + = do + res <- liftIO $ fmap sequence $ traverse (\(mb_pkg, L _ mod) -> + let reason = moduleNameString mod ++ " changed" + in classify reason <$> findImportedModule fc units home_unit dflags mod (mb_pkg)) + (ms_imps summary ++ ms_srcimps summary) + case res of + Left recomp -> return recomp + Right es -> do + let (hs, ps) = partitionEithers es + res1 <- liftIO $ check_mods (sort hs) prev_dep_mods + + let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units) + res2 <- liftIO $ check_packages allPkgDeps prev_dep_pkgs + return (res1 `mappend` res2) where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env fc = hsc_FC hsc_env home_unit = hsc_home_unit hsc_env units = hsc_units hsc_env - prev_dep_mods = dep_direct_mods (mi_deps iface) - prev_dep_plgn = dep_plgins (mi_deps iface) - prev_dep_pkgs = dep_direct_pkgs (mi_deps iface) + prev_dep_mods = map gwib_mod $ dep_direct_mods (mi_deps iface) + prev_dep_pkgs = sort (dep_direct_pkgs (mi_deps iface)) + bkpk_units = map (("Signature",) . indefUnit . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) - dep_missing (mb_pkg, L _ mod) = do - find_res <- findImportedModule fc units home_unit dflags mod (mb_pkg) - let reason = moduleNameString mod ++ " changed" - case find_res of - Found _ mod - | isHomeUnit home_unit pkg - -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn - then do trace_hi_diffs logger dflags $ - text "imported module " <> quotes (ppr mod) <> - text " not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - | otherwise - -> if toUnitId pkg `notElem` prev_dep_pkgs - then do trace_hi_diffs logger dflags $ - text "imported module " <> quotes (ppr mod) <> - text " is from package " <> quotes (ppr pkg) <> - text ", which is not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - where pkg = moduleUnit mod - _otherwise -> return (RecompBecause reason) + implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) + + + classify _ (Found _ mod) + | isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod)) + | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) + classify reason _ = Left (RecompBecause reason) + + check_mods [] [] = return UpToDate + check_mods [] (old:_) = do + -- This case can happen when a module is change from HPT to package import + trace_hi_diffs logger $ + text "module no longer " <> quotes (ppr old) <> + text "in dependencies" + return (RecompBecause (moduleNameString old ++ " removed")) + check_mods (new:news) olds + | Just (old, olds') <- uncons olds + , new == old = check_mods (dropWhile (== new) news) olds' + | otherwise = do + trace_hi_diffs logger $ + text "imported module " <> quotes (ppr new) <> + text " not among previous dependencies" + return (RecompBecause (moduleNameString new ++ " added")) + + check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired + check_packages [] [] = return UpToDate + check_packages [] (old:_) = do + trace_hi_diffs logger $ + text "package " <> quotes (ppr old) <> + text "no longer in dependencies" + return (RecompBecause (unitString old ++ " removed")) + check_packages (new:news) olds + | Just (old, olds') <- uncons olds + , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds' + | otherwise = do + trace_hi_diffs logger $ + text "imported package " <> quotes (ppr new) <> + text " not among previous dependencies" + return (RecompBecause ((fst new) ++ " package changed")) + + needInterface :: Module -> (ModIface -> IO RecompileRequired) -> IfG RecompileRequired needInterface mod continue @@ -527,10 +533,9 @@ -> IfG (Maybe a) getFromModIface doc_msg mod getter = do -- Load the imported interface if possible - dflags <- getDynFlags logger <- getLogger let doc_str = sep [text doc_msg, ppr mod] - liftIO $ trace_hi_diffs logger dflags (text "Checking interface for module" <+> ppr mod) + liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod) mb_iface <- loadInterface doc_str mod ImportBySystem -- Load the interface, but don't complain on failure; @@ -538,7 +543,7 @@ case mb_iface of Failed _ -> do - liftIO $ trace_hi_diffs logger dflags (sep [text "Couldn't load interface for module", ppr mod]) + liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod]) return Nothing -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain: it might @@ -549,35 +554,38 @@ -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage :: Unit -> Usage -> IfG RecompileRequired -checkModUsage _this_pkg UsagePackageModule{ +checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired +checkModUsage _ _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do - dflags <- getDynFlags logger <- getLogger needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed" - checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when -- a dependent package has changed. -checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do - dflags <- getDynFlags +checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do logger <- getLogger needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed (raw)" - checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) +checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do + let mod = mkModule this_pkg mod_name + logger <- getLogger + needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed (interface)" + checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) -checkModUsage this_pkg UsageHomeModule{ +checkModUsage _ this_pkg UsageHomeModule{ usg_mod_name = mod_name, usg_mod_hash = old_mod_hash, usg_exports = maybe_old_export_hash, usg_entities = old_decl_hash } = do let mod = mkModule this_pkg mod_name - dflags <- getDynFlags logger <- getLogger needInterface mod $ \iface -> do let @@ -589,32 +597,33 @@ liftIO $ do -- CHECK MODULE - recompile <- checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash + recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash if not (recompileRequired recompile) then return UpToDate else -- CHECK EXPORT LIST - checkMaybeHash logger dflags reason maybe_old_export_hash new_export_hash + checkMaybeHash logger reason maybe_old_export_hash new_export_hash (text " Export list changed") $ do -- CHECK ITEMS ONE BY ONE - recompile <- checkList [ checkEntityUsage logger dflags reason new_decl_hash u - | u <- old_decl_hash] + !recompile <- checkList [ checkEntityUsage logger reason new_decl_hash u + | u <- old_decl_hash] if recompileRequired recompile then return recompile -- This one failed, so just bail out now - else up_to_date logger dflags (text " Great! The bits I use are up to date") - + else up_to_date logger (text " Great! The bits I use are up to date") -checkModUsage _this_pkg UsageFile{ usg_file_path = file, - usg_file_hash = old_hash } = +checkModUsage fc _this_pkg UsageFile{ usg_file_path = file, + usg_file_hash = old_hash, + usg_file_label = mlabel } = liftIO $ handleIO handler $ do - new_hash <- getFileHash file + new_hash <- lookupFileCache fc file if (old_hash /= new_hash) then return recomp else return UpToDate where - recomp = RecompBecause (file ++ " changed") + reason = file ++ " changed" + recomp = RecompBecause (fromMaybe reason mlabel) handler = if debugIsOn then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the file, just recompile, don't fail @@ -622,63 +631,74 @@ ------------------------ checkModuleFingerprint :: Logger - -> DynFlags -> String -> Fingerprint -> Fingerprint -> IO RecompileRequired -checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash +checkModuleFingerprint logger reason old_mod_hash new_mod_hash | new_mod_hash == old_mod_hash - = up_to_date logger dflags (text "Module fingerprint unchanged") + = up_to_date logger (text "Module fingerprint unchanged") | otherwise - = out_of_date_hash logger dflags reason (text " Module fingerprint has changed") + = out_of_date_hash logger reason (text " Module fingerprint has changed") old_mod_hash new_mod_hash +checkIfaceFingerprint + :: Logger + -> String + -> Fingerprint + -> Fingerprint + -> IO RecompileRequired +checkIfaceFingerprint logger reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date logger (text "Iface fingerprint unchanged") + + | otherwise + = out_of_date_hash logger reason (text " Iface fingerprint has changed") + old_mod_hash new_mod_hash + ------------------------ checkMaybeHash :: Logger - -> DynFlags -> String -> Maybe Fingerprint -> Fingerprint -> SDoc -> IO RecompileRequired -> IO RecompileRequired -checkMaybeHash logger dflags reason maybe_old_hash new_hash doc continue +checkMaybeHash logger reason maybe_old_hash new_hash doc continue | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash logger dflags reason doc hash new_hash + = out_of_date_hash logger reason doc hash new_hash | otherwise = continue ------------------------ checkEntityUsage :: Logger - -> DynFlags -> String -> (OccName -> Maybe (OccName, Fingerprint)) -> (OccName, Fingerprint) -> IO RecompileRequired -checkEntityUsage logger dflags reason new_hash (name,old_hash) = do +checkEntityUsage logger reason new_hash (name,old_hash) = do case new_hash name of -- We used it before, but it ain't there now - Nothing -> out_of_date logger dflags reason (sep [text "No longer exported:", ppr name]) + Nothing -> out_of_date logger reason (sep [text "No longer exported:", ppr name]) -- It's there, but is it up to date? Just (_, new_hash) | new_hash == old_hash - -> do trace_hi_diffs logger dflags (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + -> do trace_hi_diffs logger (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) return UpToDate | otherwise - -> out_of_date_hash logger dflags reason (text " Out of date:" <+> ppr name) old_hash new_hash + -> out_of_date_hash logger reason (text " Out of date:" <+> ppr name) old_hash new_hash -up_to_date :: Logger -> DynFlags -> SDoc -> IO RecompileRequired -up_to_date logger dflags msg = trace_hi_diffs logger dflags msg >> return UpToDate +up_to_date :: Logger -> SDoc -> IO RecompileRequired +up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate -out_of_date :: Logger -> DynFlags -> String -> SDoc -> IO RecompileRequired -out_of_date logger dflags reason msg = trace_hi_diffs logger dflags msg >> return (RecompBecause reason) +out_of_date :: Logger -> String -> SDoc -> IO RecompileRequired +out_of_date logger reason msg = trace_hi_diffs logger msg >> return (RecompBecause reason) -out_of_date_hash :: Logger -> DynFlags -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired -out_of_date_hash logger dflags reason msg old_hash new_hash - = out_of_date logger dflags reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) +out_of_date_hash :: Logger -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired +out_of_date_hash logger reason msg old_hash new_hash + = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) ---------------------- checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired @@ -1071,12 +1091,14 @@ -- The interface hash depends on: -- - the ABI hash, plus + -- - the source file hash, -- - the module level annotations, -- - usages -- - deps (home and external packages, dependent files) -- - hpc iface_hash <- computeFingerprint putNameLiterally (mod_hash, + mi_src_hash iface0, ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache mi_usages iface0, sorted_deps, @@ -1151,11 +1173,12 @@ hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env pit = eps_PIT eps + ctx = initSDocContext dflags defaultUserStyle get_orph_hash mod = case lookupIfaceByModule hpt pit mod of Just iface -> return (mi_orphan_hash (mi_final_exts iface)) Nothing -> do -- similar to 'mkHashFun' - iface <- initIfaceLoad hsc_env . withException dflags + iface <- initIfaceLoad hsc_env . withException ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem return (mi_orphan_hash (mi_final_exts iface)) @@ -1171,8 +1194,7 @@ dep_trusted_pkgs = sort (dep_trusted_pkgs d), dep_boot_mods = sort (dep_boot_mods d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), - dep_finsts = sortBy stableModuleCmp (dep_finsts d), - dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) } + dep_finsts = sortBy stableModuleCmp (dep_finsts d) } {- ************************************************************************ @@ -1449,6 +1471,7 @@ dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env pit = eps_PIT eps + ctx = initSDocContext dflags defaultUserStyle occ = nameOccName name orig_mod = nameModule name lookup mod = do @@ -1460,7 +1483,7 @@ -- requirements; we didn't do any /real/ typechecking -- so there's no guarantee everything is loaded. -- Kind of a heinous hack. - initIfaceLoad hsc_env . withException dflags + initIfaceLoad hsc_env . withException ctx $ withoutDynamicNow -- For some unknown reason, we need to reset the -- dynamicNow bit, otherwise only dynamic diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -25,7 +25,6 @@ import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing import GHC.Unit -import GHC.Unit.State import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps @@ -646,8 +645,9 @@ <*> rnIfaceExpr body rnIfaceExpr (IfaceCast expr co) = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co -rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) -rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty +rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) +rnIfaceExpr (IfaceLitRubbish rep) = IfaceLitRubbish <$> rnIfaceType rep +rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr rnIfaceBndrs :: Rename [IfaceBndr] 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 @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE NamedFieldPuns #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -46,6 +47,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic +import GHC.Utils.Trace import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err @@ -77,6 +79,9 @@ import Control.Monad import Data.Function import Data.List ( sortBy, mapAccumL ) +import qualified Data.Set as S +import GHC.Platform.Ways +import GHC.Types.CostCentre {- Constructing the TypeEnv, Instances, Rules from which the @@ -144,8 +149,8 @@ -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails -mkBootModDetailsTc hsc_env +mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc logger TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, -- just for the Ids tcg_tcs = tcs, @@ -157,7 +162,7 @@ } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process. - Err.withTiming logger dflags + Err.withTiming logger (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ return (ModDetails { md_types = type_env' @@ -169,9 +174,6 @@ , md_complete_matches = complete_matches }) where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types -- @@ -365,7 +367,7 @@ , mg_modBreaks = modBreaks }) - = Err.withTiming logger dflags + = Err.withTiming logger (text "CoreTidy"<+>brackets (ppr mod)) (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags @@ -432,21 +434,28 @@ -- (c) Constructors even if they are not exported (the -- tidied TypeEnv has trimmed these away) ; alg_tycons = filter isAlgTyCon tcs + + + ; local_ccs + | WayProf `S.member` ways dflags + = collectCostCentres mod all_tidy_binds tidy_rules + | otherwise + = S.empty } ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules -- If the endPass didn't print the rules, but ddump-rules is -- on, print now - ; unless (dopt Opt_D_dump_simpl dflags) $ - Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules + ; unless (logHasDumpFlag logger Opt_D_dump_simpl) $ + Logger.putDumpFileMaybe logger Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) FormatText (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds - ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats" + ; Logger.putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" FormatText (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon @@ -457,6 +466,7 @@ ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, cg_binds = all_tidy_binds, + cg_ccs = S.toList local_ccs, cg_foreign = add_spt_init_code foreign_stubs, cg_foreign_files = foreign_files, cg_dep_pkgs = dep_direct_pkgs deps, @@ -477,6 +487,53 @@ dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + +------------------------------------------------------------------------------ +-- Collecting cost centres +-- --------------------------------------------------------------------------- + +-- | Collect cost centres defined in the current module, including those in +-- unfoldings. +collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre +collectCostCentres mod_name binds rules + = foldl' go_bind (go_rules S.empty) binds + where + go cs e = case e of + Var{} -> cs + Lit{} -> cs + App e1 e2 -> go (go cs e1) e2 + Lam _ e -> go cs e + Let b e -> go (go_bind cs b) e + Case scrt _ _ alts -> go_alts (go cs scrt) alts + Cast e _ -> go cs e + Tick (ProfNote cc _ _) e -> + go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e + Tick _ e -> go cs e + Type{} -> cs + Coercion{} -> cs + + go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e) + + go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre + go_bind cs (NonRec b e) = + go (do_binder cs b) e + go_bind cs (Rec bs) = + foldl' (\cs' (b, e) -> go (do_binder cs' b) e) cs bs + + do_binder cs b = maybe cs (go cs) (get_unf b) + + + -- Unfoldings may have cost centres that in the original definion are + -- optimized away, see #5889. + get_unf = maybeUnfoldingTemplate . realIdUnfolding + + -- Have to look at the RHS of rules as well, as these may contain ticks which + -- don't appear anywhere else. See #19894 + go_rules cs = foldl' go cs (mapMaybe get_rhs rules) + + get_rhs Rule { ru_rhs } = Just ru_rhs + get_rhs BuiltinRule {} = Nothing + -------------------------- trimId :: Bool -> Id -> Id -- With -O0 we now trim off the arity, one-shot-ness, strictness @@ -735,7 +792,7 @@ where new_needed_ids = bndrFvsInOrder show_unfold id idinfo = idInfo id - unfolding = unfoldingInfo idinfo + unfolding = realUnfoldingInfo idinfo show_unfold = show_unfolding unfolding never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isStrongLoopBreaker (occInfo idinfo) @@ -752,10 +809,20 @@ || isStableSource src -- Always expose things whose -- source is an inline rule - || not (bottoming_fn -- No need to inline bottom functions - || never_active -- Or ones that say not to - || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance guidance) + || not dont_inline + where + dont_inline + | never_active = True -- Will never inline + | loop_breaker = True -- Ditto + | otherwise = case guidance of + UnfWhen {} -> False + UnfIfGoodArgs {} -> bottoming_fn + UnfNever {} -> True + -- bottoming_fn: don't inline bottoming functions, unless the + -- RHS is very small or trivial (UnfWhen), in which case we + -- may as well do so For example, a cast might cancel with + -- the call site. + show_unfolding (DFunUnfolding {}) = True show_unfolding _ = False @@ -849,7 +916,7 @@ -- For top-level bindings (call from addExternal, via bndrFvsInOrder) -- we say "True" if we are exposing that unfolding dffvLetBndr vanilla_unfold id - = do { go_unf (unfoldingInfo idinfo) + = do { go_unf (realUnfoldingInfo idinfo) ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } where idinfo = idInfo id @@ -1239,7 +1306,7 @@ Just (arity, _) -> not (appIsDeadEnd id_sig arity) --------- Unfolding ------------ - unf_info = unfoldingInfo idinfo + unf_info = realUnfoldingInfo idinfo unfold_info | isCompulsoryUnfolding unf_info || show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -151,7 +151,7 @@ import GHC.Types.ForeignStubs import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State +import Control.Monad.Trans.State.Strict import Data.List (intercalate) import Data.Maybe import GHC.Fingerprint diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -38,6 +38,7 @@ import GHC.StgToCmm.Types +import GHC.Tc.Errors.Types import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType @@ -102,6 +103,7 @@ import GHC.Types.Id.Info import GHC.Types.Tickish import GHC.Types.TyThing +import GHC.Types.Error import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF @@ -573,9 +575,9 @@ Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (elaborate err) + IsBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints (elaborate err)) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc moduleLoop + NotBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints moduleLoop) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -1221,7 +1223,7 @@ Nothing -> return () Just errs -> do logger <- getLogger - liftIO $ displayLintResults logger dflags False doc + liftIO $ displayLintResults logger False doc (pprCoreExpr rhs') (emptyBag, errs) } ; return (bndrs', args', rhs') } @@ -1454,6 +1456,10 @@ tcIfaceExpr (IfaceExt gbl) = Var <$> tcIfaceExtId gbl +tcIfaceExpr (IfaceLitRubbish rep) + = do rep' <- tcIfaceType rep + return (Lit (LitRubbish rep')) + tcIfaceExpr (IfaceLit lit) = do lit' <- tcIfaceLit lit return (Lit lit') @@ -1743,7 +1749,7 @@ -} tcPragExpr :: Bool -- Is this unfolding compulsory? - -- See Note [Checking for levity polymorphism] in GHC.Core.Lint + -- See Note [Checking for representation polymorphism] in GHC.Core.Lint -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr) tcPragExpr is_compulsory toplvl name expr = forkM_maybe doc $ do @@ -1759,7 +1765,7 @@ case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of Nothing -> return () Just errs -> liftIO $ - displayLintResults logger dflags False doc + displayLintResults logger False doc (pprCoreExpr core_expr') (emptyBag, errs) return core_expr' where diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -57,7 +57,7 @@ , -- Only if we want dynamic libraries WayDyn `Set.member` ways dflags -- Only use RPath if we explicitly asked for it - , gopt Opt_RPath dflags + , useXLinkerRPath dflags os = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] -- See Note [-Xlinker -rpath vs -Wl,-rpath] | otherwise = ["-L" ++ l] diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -25,7 +25,6 @@ import GHC.Unit import GHC.Unit.Env -import GHC.Unit.State import GHC.Utils.Asm import GHC.Utils.Error @@ -90,7 +89,7 @@ mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - logInfo logger dflags $ withPprStyle defaultUserStyle + logInfo logger $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -238,11 +237,11 @@ | otherwise = do link_info <- getLinkInfo dflags unit_env pkg_deps - debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString logger dflags exe_file + debugTraceMsg logger 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString logger exe_file ghcLinkInfoSectionName ghcLinkInfoNoteName let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg logger dflags 3 $ case m_exe_link_info of + debugTraceMsg logger 3 $ case m_exe_link_info of Nothing -> text "Exe link info: Not found" Just s | sameLinkInfo -> text ("Exe link info is the same") 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 @@ -15,6 +15,7 @@ , initLoaderState , uninitializedLoader , showLoaderState + , getLoaderState -- * Load & Unload , loadExpr , loadDecls @@ -44,6 +45,7 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config +import GHC.Driver.Config.Diagnostic import GHC.Tc.Utils.Monad @@ -98,7 +100,7 @@ import Data.Char (isSpace) import Data.Function ((&)) import Data.IORef -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, find) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC @@ -113,6 +115,8 @@ #endif import GHC.Utils.Exception +import qualified Data.Map as M +import Data.Either (partitionEithers) uninitialised :: a uninitialised = panic "Loader not initialised" @@ -128,6 +132,10 @@ (fmapFst pure . f . fromMaybe uninitialised) where fmapFst f = fmap (\(x, y) -> (f x, y)) +getLoaderState :: Interp -> IO (Maybe LoaderState) +getLoaderState interp = readMVar (loader_state (interpLoader interp)) + + emptyLoaderState :: LoaderState emptyLoaderState = LoaderState { closure_env = emptyNameEnv @@ -135,6 +143,9 @@ , pkgs_loaded = init_pkgs , bcos_loaded = [] , objs_loaded = [] + , hs_objs_loaded = [] + , non_hs_objs_loaded = [] + , module_deps = M.empty , temp_sos = [] } -- Packages that don't need loading, because the compiler @@ -166,14 +177,14 @@ -- | Load the module containing the given Name and get its associated 'HValue'. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found. -loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue -loadName interp hsc_env name = do +loadName :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> IO ForeignHValue +loadName interp hsc_env mnwib name = do initLoaderState interp hsc_env modifyLoaderState interp $ \pls0 -> do pls <- if not (isExternalName name) then return pls0 else do - (pls', ok) <- loadDependencies interp hsc_env pls0 noSrcSpan + (pls', ok) <- loadDependencies interp hsc_env pls0 (noSrcSpan, mnwib) [nameModule name] if failed ok then throwGhcExceptionIO (ProgramError "") @@ -194,7 +205,7 @@ :: Interp -> HscEnv -> LoaderState - -> SrcSpan -> [Module] + -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> [Module] -> IO (LoaderState, SuccessFlag) loadDependencies interp hsc_env pls span needed_mods = do -- initLoaderState (hsc_dflags hsc_env) dl @@ -204,15 +215,20 @@ -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. -- So here we check the build tag: if we're building a non-standard way -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags interp span + maybe_normal_osuf <- checkNonStdWay dflags interp (fst span) -- Find what packages and linkables are required - (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods + (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls + maybe_normal_osuf (fst span) needed_mods + let pls1 = + case (snd span) of + Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) } + Nothing -> pls + -- Link the packages and modules required - pls1 <- loadPackages' interp hsc_env pkgs pls - loadModules interp hsc_env pls1 lnks + pls2 <- loadPackages' interp hsc_env pkgs pls1 + loadModules interp hsc_env pls2 lnks -- | Temporarily extend the loaded env. @@ -336,16 +352,16 @@ lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - maybePutStrLn logger dflags "Search directories (user):" - maybePutStr logger dflags (unlines $ map (" "++) lib_paths_env) - maybePutStrLn logger dflags "Search directories (gcc):" - maybePutStr logger dflags (unlines $ map (" "++) gcc_paths) + maybePutStrLn logger "Search directories (user):" + maybePutStr logger (unlines $ map (" "++) lib_paths_env) + maybePutStrLn logger "Search directories (gcc):" + maybePutStr logger (unlines $ map (" "++) gcc_paths) libspecs <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput logger dflags) + classified_ld_inputs <- mapM (classifyLdInput logger platform) [ f | FileOption _ f <- cmdline_ld_inputs ] -- (e) Link any MacOS frameworks @@ -377,13 +393,13 @@ pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls merged_specs - maybePutStr logger dflags "final link ... " + maybePutStr logger "final link ... " ok <- resolveObjs interp -- DLLs are loaded, reset the search paths mapM_ (removeLibrarySearchPath interp) $ reverse pathCache - if succeeded ok then maybePutStrLn logger dflags "done" + if succeeded ok then maybePutStrLn logger "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") return pls1 @@ -426,16 +442,15 @@ users? -} -classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput logger dflags f +classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput logger platform f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - putLogMsg logger dflags MCInfo noSrcSpan + logMsg logger MCInfo noSrcSpan $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing - where platform = targetPlatform dflags preloadLib :: Interp @@ -446,22 +461,22 @@ -> LibrarySpec -> IO LoaderState preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of Objects static_ishs -> do (b, pls1) <- preload_statics lib_paths static_ishs - maybePutStrLn logger dflags (if b then "done" else "not found") + maybePutStrLn logger (if b then "done" else "not found") return pls1 Archive static_ish -> do b <- preload_static_archive lib_paths static_ish - maybePutStrLn logger dflags (if b then "done" else "not found") + maybePutStrLn logger (if b then "done" else "not found") return pls DLL dll_unadorned -> do maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec Just mm | otherwise -> do @@ -471,14 +486,14 @@ let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL interp libfile case err2 of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just _ -> 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 dflags "done" + Nothing -> maybePutStrLn logger "done" Just mm -> preloadFailed mm lib_paths lib_spec return pls @@ -486,7 +501,7 @@ if platformUsesFrameworks (targetPlatform dflags) then do maybe_errstr <- loadFramework interp framework_paths framework case maybe_errstr of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just mm -> preloadFailed mm framework_paths lib_spec return pls else throwGhcExceptionIO (ProgramError "preloadLib Framework") @@ -499,7 +514,7 @@ preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec - = do maybePutStr logger dflags "failed.\n" + = do maybePutStr logger "failed.\n" throwGhcExceptionIO $ CmdLineError ( "user specified .o/.so/.DLL could not be loaded (" @@ -547,7 +562,7 @@ -- Raises an IO exception ('ProgramError') if it can't find a compiled -- version of the dependents to load. -- -loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue +loadExpr :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> UnlinkedBCO -> IO ForeignHValue loadExpr interp hsc_env span root_ul_bco = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env @@ -636,7 +651,7 @@ -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [UnitId]) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -647,14 +662,17 @@ ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) emptyUniqDSet emptyUniqDSet; - ; let { + ; let -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + (mods_needed, mods_got) = partitionEithers (map split_mods mods_s) + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls - linked_mods = map (moduleName.linkableModule) - (objs_loaded pls ++ bcos_loaded pls) } + split_mods mod_name = + let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls) + in case is_linked of + Just linkable -> Right linkable + Nothing -> Left mod_name -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot @@ -662,7 +680,7 @@ ; let { osuf = objectSuf dflags } ; lnks_needed <- mapM (get_linkable osuf) mods_needed - ; return (lnks_needed, pkgs_needed) } + ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env @@ -779,7 +797,7 @@ ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO () +loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO () loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env @@ -822,11 +840,11 @@ ********************************************************************* -} -loadModule :: Interp -> HscEnv -> Module -> IO () -loadModule interp hsc_env mod = do +loadModule :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Module -> IO () +loadModule interp hsc_env mnwib mod = do initLoaderState interp hsc_env modifyLoaderState_ interp $ \pls -> do - (pls', ok) <- loadDependencies interp hsc_env pls noSrcSpan [mod] + (pls', ok) <- loadDependencies interp hsc_env pls (noSrcSpan, mnwib) [mod] if failed ok then throwGhcExceptionIO (ProgramError "could not load module") else return pls' @@ -947,7 +965,7 @@ concatMap (\l -> [ Option ("-l" ++ l) ]) (nub $ snd <$> temp_sos) ++ concatMap (\lp -> Option ("-L" ++ lp) - : if gopt Opt_RPath dflags + : if useXLinkerRPath dflags (platformOS platform) then [ Option "-Xlinker" , Option "-rpath" , Option "-Xlinker" @@ -956,7 +974,7 @@ (nub $ fst <$> temp_sos) ++ concatMap (\lp -> Option ("-L" ++ lp) - : if gopt Opt_RPath dflags + : if useXLinkerRPath dflags (platformOS platform) then [ Option "-Xlinker" , Option "-rpath" , Option "-Xlinker" @@ -1110,11 +1128,10 @@ pls1 <- unload_wkr interp linkables pls return (pls1, pls1) - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - debugTraceMsg logger dflags 3 $ + debugTraceMsg logger 3 $ text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg logger dflags 3 $ + debugTraceMsg logger 3 $ text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) return () @@ -1184,40 +1201,6 @@ -- letting go of them (plus of course depopulating -- the symbol table which is done in the main body) -{- ********************************************************************** - - Loading packages - - ********************************************************************* -} - -data LibrarySpec - = Objects [FilePath] -- Full path names of set of .o files, including trailing .o - -- We allow batched loading to ensure that cyclic symbol - -- references can be resolved (see #13786). - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. - - | Archive FilePath -- Full path name of a .a file, including trailing .a - - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently - - | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). - - | Framework String -- Only used for darwin, but does no harm - -instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr objs - ppr (Archive a) = text "Archive" <+> text a - ppr (DLL s) = text "DLL" <+> text s - ppr (DLLPath f) = text "DLLPath" <+> text f - ppr (Framework s) = text "Framework" <+> text s - -- If this package is already part of the GHCi binary, we'll already -- have the right DLLs for this package loaded, so don't try to -- load them again. @@ -1263,29 +1246,31 @@ loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState loadPackages' interp hsc_env new_pks pls = do - pkgs' <- link (pkgs_loaded pls) new_pks - return $! pls { pkgs_loaded = pkgs' } + (pkgs', hs_objs, non_hs_objs) <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' + , hs_objs_loaded = hs_objs ++ hs_objs_loaded pls + , non_hs_objs_loaded = non_hs_objs ++ non_hs_objs_loaded pls } where - link :: [UnitId] -> [UnitId] -> IO [UnitId] + link :: [UnitId] -> [UnitId] -> IO ([UnitId], [LibrarySpec], [LibrarySpec]) link pkgs new_pkgs = - foldM link_one pkgs new_pkgs + foldM link_one (pkgs, [],[]) new_pkgs - link_one pkgs new_pkg + link_one (pkgs, acc_hs, acc_non_hs) new_pkg | new_pkg `elem` pkgs -- Already linked - = return pkgs + = return (pkgs, acc_hs, acc_non_hs) | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg = do { -- Link dependents first - pkgs' <- link pkgs (unitDepends pkg_cfg) + (pkgs', hs_cls', extra_cls') <- link pkgs (unitDepends pkg_cfg) -- Now link the package itself - ; loadPackage interp hsc_env pkg_cfg - ; return (new_pkg : pkgs') } + ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg + ; return (new_pkg : pkgs', acc_hs ++ hs_cls ++ hs_cls', acc_non_hs ++ extra_cls ++ extra_cls') } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO () +loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) loadPackage interp hsc_env pkg = do let dflags = hsc_dflags hsc_env @@ -1339,7 +1324,7 @@ all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath interp) all_paths_env - maybePutSDoc logger dflags + maybePutSDoc logger (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -- See comments with partOfGHCi @@ -1359,7 +1344,7 @@ mapM_ (loadObj interp) objs mapM_ (loadArchive interp) archs - maybePutStr logger dflags "linking ... " + maybePutStr logger "linking ... " ok <- resolveObjs interp -- DLLs are loaded, reset the search paths @@ -1369,7 +1354,9 @@ mapM_ (removeLibrarySearchPath interp) $ reverse pathCache if succeeded ok - then maybePutStrLn logger dflags "done." + then do + maybePutStrLn logger "done." + return (hs_classifieds, extra_classifieds) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) @@ -1430,12 +1417,12 @@ if crash_early then cmdLineErrorIO err else - when (wopt Opt_WarnMissedExtraSharedLib dflags) - $ putLogMsg logger dflags - (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib) + when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) + $ logMsg logger + (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib) noSrcSpan $ withPprStyle defaultUserStyle (note err) where - dflags = hsc_dflags hsc_env + diag_opts = initDiagOpts (hsc_dflags hsc_env) logger = hsc_logger hsc_env note err = vcat $ map text [ err @@ -1523,6 +1510,7 @@ where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + diag_opts = initDiagOpts dflags dirs = lib_dirs ++ gcc_dirs gcc = False user = True @@ -1592,10 +1580,11 @@ , not loading_dynamic_hs_libs , interpreterProfiled interp = do - warningMsg logger dflags - (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ + let diag = mkMCDiagnostic diag_opts WarningWithoutFlag + logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $ + text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ text " \tTrying dynamic library instead. If this fails try to rebuild" <+> - text "libraries with profiling support.") + text "libraries with profiling support." return (DLL lib) | otherwise = return (DLL lib) infixr `orElse` @@ -1726,16 +1715,16 @@ ********************************************************************* -} -maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO () -maybePutSDoc logger dflags s - = when (verbosity dflags > 1) $ - putLogMsg logger dflags +maybePutSDoc :: Logger -> SDoc -> IO () +maybePutSDoc logger s + = when (logVerbAtLeast logger 2) $ + logMsg logger MCInteractive noSrcSpan $ withPprStyle defaultUserStyle s -maybePutStr :: Logger -> DynFlags -> String -> IO () -maybePutStr logger dflags s = maybePutSDoc logger dflags (text s) +maybePutStr :: Logger -> String -> IO () +maybePutStr logger s = maybePutSDoc logger (text s) -maybePutStrLn :: Logger -> DynFlags -> String -> IO () -maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n") +maybePutStrLn :: Logger -> String -> IO () +maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n") 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 @@ -44,6 +44,8 @@ -- -- See Note [Dynamic linking on macOS] runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () +-- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004 +runInjectRPaths _ dflags _ _ | not (gopt Opt_RPath dflags) = return () runInjectRPaths logger dflags lib_paths dylib = do info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -95,7 +95,7 @@ (l `makeRelativeTo` full_output_fn) else l -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if gopt Opt_RPath dflags + rpath = if useXLinkerRPath dflags (platformOS platform) then ["-Xlinker", "-rpath", "-Xlinker", libpath] else [] -- Solaris 11's linker does not support -rpath-link option. It silently @@ -111,7 +111,7 @@ | osMachOTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && WayDyn `elem` ways dflags && - gopt Opt_RPath dflags + useXLinkerRPath dflags (platformOS platform) = let libpath = if gopt Opt_RelativeDynlibPaths dflags then "@loader_path" (l `makeRelativeTo` full_output_fn) @@ -222,7 +222,7 @@ not staticLink && (platformOS platform == OSDarwin) && case platformArch platform of - ArchX86 -> True + ArchX86 -> True ArchX86_64 -> True ArchARM {} -> True ArchAArch64 -> True diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -49,6 +49,7 @@ , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module +import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env @@ -453,9 +454,10 @@ ; name <- applyNameMaker name_maker rdrname ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } where - localPatternSynonymErr :: SDoc + localPatternSynonymErr :: TcRnMessage localPatternSynonymErr - = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) 2 (text "Pattern synonym declarations are only valid at top level") rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) @@ -663,9 +665,10 @@ ; return env} } -dupFixityDecl :: SrcSpan -> RdrName -> SDoc +dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage dupFixityDecl loc rdr_name - = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), text "also at " <+> ppr loc] @@ -753,9 +756,10 @@ -- See Note [Renaming pattern synonym variables] lookupPatSynBndr = wrapLocMA lookupLocalOccRn - patternSynonymErr :: SDoc + patternSynonymErr :: TcRnMessage patternSynonymErr - = hang (text "Illegal pattern synonym declaration") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal pattern synonym declaration") 2 (text "Use -XPatternSynonyms to enable this extension") {- @@ -910,7 +914,7 @@ -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt (locA loc) $ + = do { addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ what <+> text "not allowed in" <+> decl_sort , nest 2 (ppr bind) ] ; return rest } @@ -1056,8 +1060,8 @@ return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs) where - orphanError :: SDoc - orphanError = + orphanError :: TcRnMessage + orphanError = TcRnUnknownMessage $ mkPlainError noHints $ text "Orphan COMPLETE pragmas not supported" $$ text "A COMPLETE pragma must mention at least one data constructor" $$ text "or pattern synonym defined in the same module." @@ -1217,9 +1221,10 @@ ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) } -emptyCaseErr :: HsMatchContext GhcRn -> SDoc -emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) - 2 (text "Use EmptyCase to allow this") +emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage +emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Empty list of alternatives in" <+> pp_ctxt) + 2 (text "Use EmptyCase to allow this") where pp_ctxt = case ctxt of CaseAlt -> text "case expression" @@ -1260,8 +1265,10 @@ ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ -> rnBody rhs - ; unless (pattern_guards_allowed || is_standard_guard guards') - (addDiagnostic WarningWithoutFlag (nonStdGuardErr guards')) + ; unless (pattern_guards_allowed || is_standard_guard guards') $ + let diag = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards') + in addDiagnostic diag ; return (GRHS noAnn guards' rhs', fvs) } where @@ -1314,7 +1321,7 @@ dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Duplicate" <+> what_it_is <> text "s for" <+> quotes (ppr name) , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest @@ -1326,17 +1333,18 @@ misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] -defaultSigErr :: Sig GhcPs -> SDoc -defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] +defaultSigErr :: Sig GhcPs -> TcRnMessage +defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Unexpected default signature:") + 2 (ppr sig) + , text "Use DefaultSignatures to enable default signatures" ] bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM () bindInHsBootFileErr (L loc _) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Bindings in hs-boot files are not allowed" ] nonStdGuardErr :: (Outputable body, @@ -1348,7 +1356,7 @@ dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Multiple minimal complete definitions" , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs) , text "Combine alternative minimal complete definitions with `|'" ] 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 @@ -64,6 +64,7 @@ import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace ) @@ -72,6 +73,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail +import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) @@ -389,7 +391,8 @@ -- when it's used cls doc rdr ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } + Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + ; return (mkUnboundNameRdr rdr) } Right nm -> return nm } where doc = what <+> text "of class" <+> quotes (ppr cls) @@ -436,7 +439,7 @@ ; case men of FoundExactOrOrig n -> return (res n) ExactOrOrigError e -> - do { addErr e + do { addErr (TcRnUnknownMessage $ mkPlainError noHints e) ; return (res (mkUnboundNameRdr rdr_name)) } NotExactOrOrig -> k } @@ -1088,9 +1091,11 @@ ; case mb_demoted_name of Nothing -> unboundNameX looking_for rdr_name star_info Just demoted_name -> - do { addDiagnostic - (WarningWithFlag Opt_WarnUntickedPromotedConstructors) - (untickedPromConstrWarn demoted_name) + do { let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnUntickedPromotedConstructors) + noHints + (untickedPromConstrWarn demoted_name) + ; addDiagnostic msg ; return demoted_name } } else do { -- We need to check if a data constructor of this name is -- in scope to give good error messages. However, we do @@ -1129,8 +1134,9 @@ badVarInType :: RdrName -> RnM Name badVarInType rdr_name - = do { addErr (text "Illegal promoted term variable in a type:" - <+> ppr rdr_name) + = do { addErr (TcRnUnknownMessage $ mkPlainError noHints + (text "Illegal promoted term variable in a type:" + <+> ppr rdr_name)) ; return (mkUnboundNameRdr rdr_name) } {- Note [Promoted variables in types] @@ -1570,8 +1576,13 @@ -- See Note [Handling of deprecations] do { iface <- loadInterfaceForName doc name ; case lookupImpDeprec iface gre of - Just txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) - (mk_msg imp_spec txt) + Just txt -> do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) + noHints + (mk_msg imp_spec txt) + + addDiagnostic msg Nothing -> return () } } | otherwise = return () @@ -1809,7 +1820,8 @@ = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } + Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + ; return (mkUnboundNameRdr rdr_name) } Right name -> return name } -- | Lookup a name in relation to the names in a 'HsSigCtxt' @@ -1821,7 +1833,8 @@ = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } + Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + ; return (mkUnboundNameRdr rdr_name) } Right name -> return name } lookupBindGroupOcc :: HsSigCtxt @@ -1923,7 +1936,8 @@ lookupLocalTcNames ctxt what rdr_name = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) ; let (errs, names) = partitionEithers mb_gres - ; when (null names) $ addErr (head errs) -- Bleat about one only + ; when (null names) $ + addErr (TcRnUnknownMessage $ mkPlainError noHints (head errs)) -- Bleat about one only ; return names } where lookup rdr = do { this_mod <- getModule @@ -2115,19 +2129,20 @@ -- Error messages -opDeclErr :: RdrName -> SDoc +opDeclErr :: RdrName -> TcRnMessage opDeclErr n - = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) 2 (text "Use TypeOperators to declare operators in type and declarations") -badOrigBinding :: RdrName -> SDoc +badOrigBinding :: RdrName -> TcRnMessage badOrigBinding name | Just _ <- isBuiltInOcc_maybe occ - = text "Illegal binding of built-in syntax:" <+> ppr occ + = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal binding of built-in syntax:" <+> ppr occ -- Use an OccName here because we don't want to print Prelude.(,) | otherwise - = text "Cannot redefine a Name retrieved by a Template Haskell quote:" - <+> ppr name + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name -- This can happen when one tries to use a Template Haskell splice to -- define a top-level identifier with an already existing name, e.g., -- diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -1,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -30,6 +32,7 @@ import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS , rnMatchGroup, rnGRHS, makeMiniFixityEnv) import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env ( isBrackStage ) import GHC.Tc.Utils.Monad import GHC.Unit.Module ( getModule ) @@ -39,7 +42,10 @@ , bindLocalNames , mapMaybeFvRn, mapFvRn , warnUnusedLocalBinds, typeAppErr - , checkUnusedRecordWildcard ) + , checkUnusedRecordWildcard + , wrapGenSpan, genHsIntegralLit, genHsTyLit + , genHsVar, genLHsVar, genHsApp, genHsApps + , genAppType ) import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName ) import GHC.Rename.HsType @@ -62,7 +68,6 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc -import GHC.Data.FastString import Control.Monad import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt @@ -106,7 +111,10 @@ This is accomplished by lookupSyntaxName, and it applies to all the constructs below. -Here are the constructs that we transform in this way. Some are uniform, +See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat +for the story with patterns. + +Here are the expressions that we transform in this way. Some are uniform, but several have a little bit of special treatment: * HsIf (if-the-else) @@ -130,7 +138,7 @@ * SectionL and SectionR (left and right sections) (`op` e) ==> rightSection op e (e `op`) ==> leftSection (op e) - where `leftSection` and `rightSection` are levity-polymorphic + where `leftSection` and `rightSection` are representation-polymorphic wired-in Ids. See Note [Left and right sections] * It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion` @@ -294,7 +302,10 @@ _ -> return (Fixity NoSourceText minPrecedence InfixL) -- c.f. lookupFixity for unbound - ; final_e <- mkOpAppRn e1' op' fixity e2' + ; lexical_negation <- xoptM LangExt.LexicalNegation + ; let negation_handling | lexical_negation = KeepNegationIntact + | otherwise = ReassociateNegation + ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2' ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } rnExpr (NegApp _ e _) @@ -393,7 +404,7 @@ do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) - hs_lit = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n)) + hs_lit = genHsIntegralLit lit_n exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } @@ -434,11 +445,13 @@ } Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. do { ; unlessXOptM LangExt.RebindableSyntax $ - addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] ; punsEnabled <-xoptM LangExt.RecordPuns ; unless (null punnedFields || punsEnabled) $ - addErr $ text "For this to work enable NamedFieldPuns." + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "For this to work enable NamedFieldPuns." ; (getField, fv_getField) <- lookupSyntaxName getFieldName ; (setField, fv_setField) <- lookupSyntaxName setFieldName ; (e, fv_e) <- rnLExpr expr @@ -513,12 +526,13 @@ -- absolutely prepared to cope with static forms, we check for -- -XStaticPointers here as well. unlessXOptM LangExt.StaticPointers $ - addErr $ hang (text "Illegal static expression:" <+> ppr e) + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal static expression:" <+> ppr e) 2 (text "Use StaticPointers to enable this extension") (expr',fvExpr) <- rnLExpr expr stage <- getStage case stage of - Splice _ -> addErr $ sep + Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep [ text "static forms cannot be used in splices:" , nest 2 $ ppr e ] @@ -613,19 +627,19 @@ sections , but only to eliminate special-purpose code paths in the renamer and desugarer. -* leftSection and rightSection must be levity-polymorphic, to allow +* leftSection and rightSection must be representation-polymorphic, to allow (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make. Note [Wired-in Ids for rebindable syntax] in * leftSection and rightSection must be multiplicity-polymorphic. (Test linear/should_compile/OldList showed this up.) -* Because they are levity-polymorphic, we have to define them +* Because they are representation-polymorphic, we have to define them as wired-in Ids, with compulsory inlining. See GHC.Types.Id.Make.leftSectionId, rightSectionId. * leftSection is just ($) really; but unlike ($) it is - levity polymorphic in the result type, so we can write + representation-polymorphic in the result type, so we can write `(x +#)`, say. * The type of leftSection must have an arrow in its first argument, @@ -1261,7 +1275,8 @@ ; return ((seg':segs', thing), fvs) } cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" + dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (NE.head vs))) lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) @@ -2138,9 +2153,9 @@ can do with the rest of the statements in the same "do" expression. -} -isStrictPattern :: LPat (GhcPass p) -> Bool -isStrictPattern lpat = - case unLoc lpat of +isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool +isStrictPattern (L loc pat) = + case pat of WildPat{} -> False VarPat{} -> False LazyPat{} -> False @@ -2157,7 +2172,16 @@ NPat{} -> True NPlusKPat{} -> True SplicePat{} -> True - XPat{} -> panic "isStrictPattern: XPat" + XPat ext -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon ext +#endif + GhcRn + | HsPatExpanded _ p <- ext + -> isStrictPattern (L loc p) + GhcTc -> case ext of + ExpansionPat _ p -> isStrictPattern (L loc p) + CoPat {} -> panic "isStrictPattern: CoPat" {- Note [ApplicativeDo and refutable patterns] @@ -2312,10 +2336,13 @@ okEmpty (PatGuard {}) = True okEmpty _ = False -emptyErr :: HsStmtContext GhcRn -> SDoc -emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" -emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" -emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt +emptyErr :: HsStmtContext GhcRn -> TcRnMessage +emptyErr (ParStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ + text "Empty statement group in parallel comprehension" +emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ + text "Empty statement group preceding 'group' or 'then'" +emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ + text "Empty" <+> pprStmtContext ctxt ---------------------- checkLastStmt :: AnnoBody body => HsStmtContext GhcRn @@ -2335,7 +2362,9 @@ BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) - _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + _ -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang last_error 2 (ppr stmt)) + ; return lstmt } last_error = (text "The last statement in" <+> pprAStmtContext ctxt <+> text "must be an expression") @@ -2355,7 +2384,7 @@ = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of IsValid -> return () - NotValid extra -> addErr (msg $$ extra) } + NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) } where msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" , text "in" <+> pprAStmtContext ctxt ] @@ -2441,17 +2470,21 @@ = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } where - msg = text "Illegal tuple section: use TupleSections" + msg :: TcRnMessage + msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal tuple section: use TupleSections" --------- -sectionErr :: HsExpr GhcPs -> SDoc +sectionErr :: HsExpr GhcPs -> TcRnMessage sectionErr expr - = hang (text "A section must be enclosed in parentheses") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) -badIpBinds :: Outputable a => SDoc -> a -> SDoc +badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage badIpBinds what binds - = hang (text "Implicit-parameter bindings illegal in" <+> what) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Implicit-parameter bindings illegal in" <+> what) 2 (ppr binds) --------- @@ -2542,29 +2575,6 @@ See Note [Handling overloaded and rebindable constructs] * * ********************************************************************* -} - -genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn -genHsApps fun args = foldl genHsApp (genHsVar fun) args - -genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg - -genLHsVar :: Name -> LHsExpr GhcRn -genLHsVar nm = wrapGenSpan $ genHsVar nm - -genHsVar :: Name -> HsExpr GhcRn -genHsVar nm = HsVar noExtField $ wrapGenSpan nm - -genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn -genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan - -genHsTyLit :: FastString -> HsType GhcRn -genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText - -wrapGenSpan :: a -> LocatedAn an a --- Wrap something in a "generatedSrcSpan" --- See Note [Rebindable syntax and HsExpansion] -wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x -- | Build a 'HsExpansion' out of an extension constructor, -- and the two components of the expansion: original and diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -24,6 +24,7 @@ rnScaledLHsType, -- Precence related stuff + NegationHandling(..), mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, @@ -54,6 +55,7 @@ import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names @@ -61,6 +63,7 @@ import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel +import GHC.Types.Error import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity @@ -207,7 +210,7 @@ -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided, -- so we currently reject. when (not (null varsInScope)) $ - addErr $ + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Type variable" <> plural varsInScope <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope)) @@ -443,8 +446,11 @@ rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case (x :| []) -> return x - (x :| _) -> do addErr $ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "." - return x + (x :| _) -> do + let msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "." + addErr msg + return x ; traceRn "rnImplicitTvBndrs" $ vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] @@ -617,7 +623,7 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ - unlessXOptM LangExt.PolyKinds $ addErr $ + unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext (rtke_ctxt env) $ vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) , text "Perhaps you intended to use PolyKinds" ] @@ -652,8 +658,8 @@ get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names get_fields _ - = do { addErr (hang (text "Record syntax is illegal here:") - 2 (ppr ty)) + = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "Record syntax is illegal here:") 2 (ppr ty)) ; return [] } rnHsTyKi env (HsFunTy u mult ty1 ty2) @@ -703,7 +709,9 @@ negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLit (HsCharTy _ _) = False - negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit + negLitErr :: TcRnMessage + negLitErr = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit rnHsTyKi env (HsAppTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 @@ -744,8 +752,9 @@ check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name when (isNothing mb_name) $ - addErr $ withHsDocContext (rtke_ctxt env) $ - notInScopeErr WL_LocalOnly rdr_name + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + withHsDocContext (rtke_ctxt env) $ + notInScopeErr WL_LocalOnly rdr_name rnHsTyKi env ty@(HsExplicitListTy _ ip tys) = do { data_kinds <- xoptM LangExt.DataKinds @@ -764,10 +773,11 @@ ; return (HsWildCardTy noExtField, emptyFVs) } rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) -rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs) -rnHsArrow _env (HsLinearArrow u a) = return (HsLinearArrow u a, emptyFVs) -rnHsArrow env (HsExplicitMult u a p) - = (\(mult, fvs) -> (HsExplicitMult u a mult, fvs)) <$> rnLHsTyKi env p +rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs) +rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs) +rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs) +rnHsArrow env (HsExplicitMult pct p arr) + = (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p {- Note [Renaming HsCoreTys] @@ -823,7 +833,7 @@ = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op ; unless (ops_ok || op' `hasKey` eqTyConKey) $ - addErr (opTyErr op overall_ty) + addErr $ TcRnUnknownMessage $ mkPlainError noHints (opTyErr op overall_ty) ; let l_op' = L loc op' ; return (l_op', unitFV op') } @@ -834,7 +844,8 @@ checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () checkWildCard env (Just doc) - = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] checkWildCard _ Nothing = return () @@ -905,8 +916,9 @@ | isRnKindLevel env = do { polykinds <- xoptM LangExt.PolyKinds ; unless polykinds $ - addErr (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable PolyKinds?") } + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Illegal kind:" <+> ppr ty $$ + text "Did you mean to enable PolyKinds?") } checkPolyKinds _ _ = return () notInKinds :: Outputable ty @@ -915,7 +927,8 @@ -> RnM () notInKinds env ty | isRnKindLevel env - = addErr (text "Illegal kind:" <+> ppr ty) + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal kind:" <+> ppr ty notInKinds _ _ = return () {- ***************************************************** @@ -1341,20 +1354,21 @@ --------------------------- -mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged +mkOpAppRn :: NegationHandling + -> LHsExpr GhcRn -- Left operand; already rearranged -> LHsExpr GhcRn -> Fixity -- Operator and fixity -> LHsExpr GhcRn -- Right operand (not an OpApp, but might -- be a NegApp) -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 +mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do - new_e <- mkOpAppRn e12 op2 fix2 e2 + new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2 return (OpApp fix1 e11 op1 (L loc' new_e)) where loc'= combineLocsA e12 e2 @@ -1362,13 +1376,13 @@ --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn ReassociateNegation e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right - = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 + = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2 return (NegApp noExtField (L loc' new_e) neg_name) where loc' = combineLocsA neg_arg e2 @@ -1376,7 +1390,7 @@ --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right +mkOpAppRn ReassociateNegation e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) return (OpApp fix1 e1 op1 e2) @@ -1385,11 +1399,13 @@ --------------------------- -- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment +mkOpAppRn _ e1 op fix e2 -- Default case, no rearrangment = assertPpr (right_op_ok fix (unLoc e2)) (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $ return (OpApp fix e1 op e2) +data NegationHandling = ReassociateNegation | KeepNegationIntact + ---------------------------- -- | Name of an operator in an operator application or section @@ -1588,7 +1604,8 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ hang (text "Precedence parsing error") + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Precedence parsing error") 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", ppr_opfix op2, text "in the same infix expression"]) @@ -1598,7 +1615,8 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", nest 4 (sep [text "must have lower precedence than that of the operand,", nest 2 (text "namely" <+> ppr_opfix arg_op)]), nest 4 (text "in the section:" <+> quotes (ppr section))] @@ -1621,21 +1639,23 @@ * * ***************************************************** -} -unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc +unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty - = hang (text "Illegal type signature:" <+> quotes (ppr ty)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal type signature:" <+> quotes (ppr ty)) 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) - = setSrcSpanA loc $ addErr $ + = setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) 2 (text "Perhaps you intended to use KindSignatures") -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc +dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage dataKindsErr env thing - = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) 2 (text "Perhaps you intended to use DataKinds") where pp_what | isRnKindLevel env = text "kind" @@ -1644,10 +1664,12 @@ warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names - = unless (hsTyVarName tv `elemNameSet` used_names) $ - addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) - , inHsDocContext doc ] + = unless (hsTyVarName tv `elemNameSet` used_names) $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $ + vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) + , inHsDocContext doc ] + addDiagnosticAt (locA loc) msg opTyErr :: Outputable a => RdrName -> a -> SDoc opTyErr op overall_ty @@ -1891,8 +1913,8 @@ extractConDeclGADTDetailsTyVars :: HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars extractConDeclGADTDetailsTyVars con_args = case con_args of - PrefixConGADT args -> extract_scaled_ltys args - RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds + PrefixConGADT args -> extract_scaled_ltys args + RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order: @@ -1966,7 +1988,7 @@ extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars -extract_hs_arrow (HsExplicitMult _ _ p) acc = extract_lty p acc +extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc extract_hs_arrow _ acc = acc extract_hs_for_all_telescope :: HsForAllTelescope GhcPs 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 @@ -22,6 +22,7 @@ import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs +import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType @@ -35,6 +36,7 @@ , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -295,10 +297,11 @@ -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements -dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc +dupWarnDecl :: LocatedN RdrName -> RdrName -> TcRnMessage -- Located RdrName -> DeprecDecl RdrName -> SDoc dupWarnDecl d rdr_name - = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), text "also at " <+> ppr (getLocA d)] {- @@ -541,36 +544,40 @@ isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 refURL flag lhs rhs = - addDiagnostic (WarningWithFlag flag) $ vcat - [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - , text "See also:" <+> - text refURL - ] + addWarnNonCanonicalMethod1 refURL flag lhs rhs = do + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag flag) noHints $ + vcat [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Move definition from" <+> + quotes (text rhs) <+> + text "to" <+> quotes (text lhs) + , text "See also:" <+> + text refURL + ] + addDiagnostic dia -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 refURL flag lhs rhs = - addDiagnostic (WarningWithFlag flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , quotes (text lhs) <+> - text "will eventually be removed in favour of" <+> - quotes (text rhs) - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "(recommended)" <+> - text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - , text "See also:" <+> - text refURL - ] + addWarnNonCanonicalMethod2 refURL flag lhs rhs = do + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag flag) noHints $ + vcat [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , quotes (text lhs) <+> + text "will eventually be removed in favour of" <+> + quotes (text rhs) + , text "Either remove definition for" <+> + quotes (text lhs) <+> text "(recommended)" <+> + text "or define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + , text "See also:" <+> + text refURL + ] + addDiagnostic dia -- stolen from GHC.Tc.TyCl.Instance instDeclCtxt1 :: LHsSigType GhcRn -> SDoc @@ -665,7 +672,7 @@ -- reach the typechecker, lest we encounter different errors that are -- hopelessly confusing (such as the one in #16114). bail_out (l, err_msg) = do - addErrAt l $ withHsDocContext ctxt err_msg + addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) pure $ mkUnboundName (mkTcOccFS (fsLit "")) rnFamEqn :: HsDocContext @@ -829,7 +836,8 @@ badAssocRhs :: [Name] -> RnM () badAssocRhs ns - = addErr (hang (text "The RHS of an associated type declaration mentions" + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "The RHS of an associated type declaration mentions" <+> text "out-of-scope variable" <> plural ns <+> pprWithCommas (quotes . ppr) ns) 2 (text "All such variables must be bound on the LHS")) @@ -1189,9 +1197,10 @@ loc = getLocA nowc_ty nowc_ty = dropWildCards ty -standaloneDerivErr :: SDoc +standaloneDerivErr :: TcRnMessage standaloneDerivErr - = hang (text "Illegal standalone deriving declaration") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal standalone deriving declaration") 2 (text "Use StandaloneDeriving to enable this extension") {- @@ -1332,15 +1341,17 @@ checkl_es es = foldr (mplus . checkl_e) Nothing es -} -badRuleVar :: FastString -> Name -> SDoc +badRuleVar :: FastString -> Name -> TcRnMessage badRuleVar name var - = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, text "Forall'd variable" <+> quotes (ppr var) <+> text "does not appear on left hand side"] -badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage badRuleLhsErr name lhs bad_e - = sep [text "Rule" <+> pprRuleName name <> colon, + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "Rule" <+> pprRuleName name <> colon, nest 2 (vcat [err, text "in left-hand side:" <+> ppr lhs])] $$ @@ -1600,8 +1611,8 @@ ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } where - standaloneKiSigErr :: SDoc - standaloneKiSigErr = + standaloneKiSigErr :: TcRnMessage + standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal standalone kind signature") 2 (text "Did you mean to enable StandaloneKindSignatures?") @@ -1674,7 +1685,7 @@ dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Duplicate role annotations for" <+> quotes (ppr $ roleAnnotDeclName first_decl) <> colon) 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) @@ -1689,7 +1700,7 @@ dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list - = addErrAt (locA loc) $ + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Duplicate standalone kind signatures for" <+> quotes (ppr $ standaloneKindSigName first_decl) <> colon) 2 (vcat $ map pp_kisig $ NE.toList sorted_list) @@ -1966,13 +1977,14 @@ warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags ; case mds of - Nothing -> addDiagnosticAt - (WarningWithFlag Opt_WarnMissingDerivingStrategies) - loc - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) + Nothing -> + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $ + (if xopt LangExt.DerivingStrategies dyn_flags + then no_strat_warning + else no_strat_warning $+$ deriv_strat_nenabled + ) + in addDiagnosticAt loc dia _ -> pure () } where @@ -2072,14 +2084,16 @@ (thing, fvs) <- thing_inside pure (ds, thing, fvs) -badGadtStupidTheta :: HsDocContext -> SDoc +badGadtStupidTheta :: HsDocContext -> TcRnMessage badGadtStupidTheta _ - = vcat [text "No context is allowed on a GADT-style data declaration", + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "No context is allowed on a GADT-style data declaration", text "(You can put a context on each constructor, though.)"] -illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc +illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage illegalDerivStrategyErr ds - = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds , text enableStrategy ] where @@ -2090,9 +2104,10 @@ | otherwise = "Use DerivingStrategies to enable this extension" -multipleDerivClausesErr :: SDoc +multipleDerivClausesErr :: TcRnMessage multipleDerivClausesErr - = vcat [ text "Illegal use of multiple, consecutive deriving clauses" + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal use of multiple, consecutive deriving clauses" , text "Use DerivingStrategies to allow this" ] rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested @@ -2157,7 +2172,7 @@ rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLocA tvbndr) $ + addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $ (hsep [ text "Type variable", quotes (ppr resName) <> comma , text "naming a type family result," ] $$ @@ -2229,7 +2244,7 @@ -- not-in-scope variables) don't check the validity of injectivity -- annotation. This gives better error messages. ; when (noRnErrors && not lhsValid) $ - addErrAt (getLocA injFrom) + addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $ ( vcat [ text $ "Incorrect type variable on the LHS of " ++ "injectivity condition" , nest 5 @@ -2238,7 +2253,8 @@ ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid - ; addErrAt srcSpan $ ( hsep + ; addErrAt srcSpan $ TcRnUnknownMessage $ mkPlainError noHints $ + ( hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:" , interpp'SP errorVars ] ) } @@ -2389,9 +2405,9 @@ rnConDeclGADTDetails _ doc (PrefixConGADT tys) = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys ; return (PrefixConGADT new_tys, fvs) } -rnConDeclGADTDetails con doc (RecConGADT flds) +rnConDeclGADTDetails con doc (RecConGADT flds arr) = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds - ; return (RecConGADT new_flds, fvs) } + ; return (RecConGADT new_flds arr, fvs) } rnRecConDeclFields :: Name @@ -2516,7 +2532,9 @@ ; return (gp, Just (splice, ds)) } where - badImplicitSplice = text "Parse error: module header, import declaration" + badImplicitSplice :: TcRnMessage + badImplicitSplice = TcRnUnknownMessage $ mkPlainError noHints $ + text "Parse error: module header, import declaration" $$ text "or top-level declaration expected." -- The compiler should suggest the above, and not using -- TemplateHaskell since the former suggestion is more diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -55,6 +55,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic +import GHC.Utils.Trace import GHC.Types.Fixity.Env import GHC.Types.SafeHaskell @@ -71,6 +72,7 @@ import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.Unique.FM +import GHC.Types.Error import GHC.Unit import GHC.Unit.Module.Warnings @@ -109,7 +111,7 @@ and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends on. To avoid this we make use of the property that if a modules Safe Haskell -mode changes, this triggers a recompilation from that module in the dependcy +mode changes, this triggers a recompilation from that module in the dependecy graph. So we can just worry mostly about direct imports. There is one trust property that can change for a package though without @@ -185,21 +187,25 @@ -- the return types represent. -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary -rnImports :: [LImportDecl GhcPs] +rnImports :: [(LImportDecl GhcPs, SDoc)] -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do tcg_env <- getGblEnv -- NB: want an identity module here, because it's OK for a signature -- module to import from its implementor let this_mod = tcg_mod tcg_env - let (source, ordinary) = partition is_source_import imports + let (source, ordinary) = partition (is_source_import . fst) imports is_source_import d = ideclSource (unLoc d) == IsBoot stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary stuff2 <- mapAndReportM (rnImportDecl this_mod) source -- Safe Haskell: See Note [Tracking Trust Transitively] let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) -- Update imp_boot_mods if imp_direct_mods mentions any of them - let final_import_avail = clobberSourceImports imp_avails + let merged_import_avail = clobberSourceImports imp_avails + dflags <- getDynFlags + let final_import_avail = + merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) + `S.union` imp_dep_direct_pkgs merged_import_avail} return (decls, rdr_env, final_import_avail, hpc_usage) where @@ -293,14 +299,14 @@ -- -- 4. A boolean 'AnyHpcUsage' which is true if the imported module -- used HPC. -rnImportDecl :: Module -> LImportDecl GhcPs +rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc) -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name , ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe , ideclQualified = qual_style, ideclImplicit = implicit - , ideclAs = as_mod, ideclHiding = imp_details })) + , ideclAs = as_mod, ideclHiding = imp_details }), import_reason) = setSrcSpanA loc $ do when (isJust mb_pkg) $ do @@ -312,7 +318,7 @@ -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' let imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> text "is directly imported" + doc = ppr imp_mod_name <+> import_reason -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not @@ -334,7 +340,8 @@ Nothing -> True Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" || fsToUnit pkg_fs == moduleUnit this_mod)) - (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) + (addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "A module cannot import itself:" <+> ppr imp_mod_name)) -- Check for a missing import list (Opt_WarnMissingImportList also -- checks for T(..) items but that is done in checkDodgyImport below) @@ -342,10 +349,14 @@ Just (False, _) -> return () -- Explicit import list _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () - | otherwise -> whenWOptM Opt_WarnMissingImportList $ - addDiagnostic (WarningWithFlag Opt_WarnMissingImportList) - (missingImportListWarn imp_mod_name) + | otherwise -> whenWOptM Opt_WarnMissingImportList $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList) + noHints + (missingImportListWarn imp_mod_name) + addDiagnostic msg + iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) -- Compiler sanity check: if the import didn't say @@ -364,7 +375,8 @@ warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ - addErr (text "safe import can't be used as Safe Haskell isn't on!" + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "safe import can't be used as Safe Haskell isn't on!" $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe")) let @@ -403,8 +415,12 @@ -- Complain if we import a deprecated module case mi_warns iface of - WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) - (moduleWarn imp_mod_name txt) + WarnAll txt -> do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) + noHints + (moduleWarn imp_mod_name txt) + addDiagnostic msg _ -> return () -- Complain about -Wcompat-unqualified-imports violations. @@ -537,8 +553,12 @@ -- Currently not used for anything. warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface = - when bad_import - $ addDiagnosticAt (WarningWithFlag Opt_WarnCompatUnqualifiedImports) loc warning + when bad_import $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports) + noHints + warning + addDiagnosticAt loc msg where mod = mi_module iface loc = getLoc $ ideclName decl @@ -566,10 +586,10 @@ qualifiedMods = mkModuleSet [] -warnRedundantSourceImport :: ModuleName -> SDoc +warnRedundantSourceImport :: ModuleName -> TcRnMessage warnRedundantSourceImport mod_name - = text "Unnecessary {-# SOURCE #-} in the import of module" - <+> quotes (ppr mod_name) + = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) {- ************************************************************************ @@ -888,7 +908,7 @@ = [( find_con_name rdr , concatMap find_con_decl_flds (unLoc cdflds) )] find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_g_args = RecConGADT flds })) + , con_g_args = RecConGADT flds _ })) = [ ( find_con_name rdr , concatMap find_con_decl_flds (unLoc flds)) | L _ rdr <- rdrs ] @@ -1185,12 +1205,18 @@ addTcRnDiagnostic (TcRnDodgyImports n) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ addTcRnDiagnostic (TcRnMissingImportList ieRdr) - emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ - addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) + emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports) + noHints + (lookup_err_msg (BadImport ie)) + addDiagnostic msg run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of - Failed err -> addErr (lookup_err_msg err) >> return Nothing + Failed err -> do + addErr $ TcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) + return Nothing Succeeded a -> return (Just a) lookup_err_msg err = case err of @@ -1562,8 +1588,10 @@ = Opt_WarnMissingExportedSignatures add_warn name flag msg - = when not_ghc_generated - (addDiagnosticAt (WarningWithFlag flag) (getSrcSpan name) msg) + = when not_ghc_generated $ do + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag flag) noHints msg + addDiagnosticAt (getSrcSpan name) dia where not_ghc_generated = name `elemNameSet` sig_ns @@ -1584,9 +1612,11 @@ ksig_ns = tcg_ksigs gbl_env add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) () - add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $ - addDiagnosticAt (WarningWithFlag Opt_WarnMissingKindSignatures) (getSrcSpan name) $ - hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg) + add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $ do + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingKindSignatures) noHints $ + hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg) + addDiagnosticAt (getSrcSpan name) dia where msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:" | otherwise = text "Top-level type constructor with no standalone kind signature:" @@ -1752,7 +1782,9 @@ -- Nothing used; drop entire declaration | null used - = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg1 + = let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag flag) noHints msg1 + in addDiagnosticAt (locA loc) dia -- Everything imported is used; nop | null unused @@ -1763,11 +1795,13 @@ | Just (_, L _ imports) <- ideclHiding decl , length unused == 1 , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg2 + = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 + in addDiagnosticAt (locA loc) dia -- Some imports are unused | otherwise - = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg2 + = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 + in addDiagnosticAt (locA loc) dia where msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant @@ -2058,7 +2092,7 @@ addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _) - = addErrAt (getSrcSpan (last sorted_names)) $ + = addErrAt (getSrcSpan (last sorted_names)) $ TcRnUnknownMessage $ mkPlainError noHints $ -- Report the error at the later location vcat [text "Multiple declarations of" <+> quotes (ppr (greOccName gre)), @@ -2087,9 +2121,10 @@ <+> text "is deprecated:", nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] -packageImportErr :: SDoc +packageImportErr :: TcRnMessage packageImportErr - = text "Package-qualified imports are not enabled; use PackageImports" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Package-qualified imports are not enabled; use PackageImports" -- This data decl will parse OK -- data T = a Int @@ -2104,6 +2139,7 @@ checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name) (badDataCon name) -badDataCon :: RdrName -> SDoc +badDataCon :: RdrName -> TcRnMessage badDataCon name - = hsep [text "Illegal data constructor name", quotes (ppr name)] + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Illegal data constructor name", quotes (ppr name)] 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 @@ -49,6 +49,7 @@ import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk ( hsOverLitName ) import GHC.Rename.Env @@ -56,10 +57,12 @@ import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard - , checkDupNames, checkDupAndShadowedNames ) + , checkDupNames, checkDupAndShadowedNames + , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit ) import GHC.Rename.HsType import GHC.Builtin.Names import GHC.Types.Avail ( greNameMangledName ) +import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader @@ -294,6 +297,85 @@ See #12615 for some more examples. +Note [Handling overloaded and rebindable patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overloaded paterns and rebindable patterns are desugared in the renamer +using the HsPatExpansion mechanism detailed in: +Note [Rebindable syntax and HsExpansion] +The approach is similar to that of expressions, which is further detailed +in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr. + +Here are the patterns that are currently desugared in this way: + +* ListPat (list patterns [p1,p2,p3]) + When (and only when) OverloadedLists is on, desugar to a view pattern: + [p1, p2, p3] + ==> + toList -> [p1, p2, p3] + ^^^^^^^^^^^^ built-in (non-overloaded) list pattern + NB: the type checker and desugarer still see ListPat, + but to them it always means the built-in list pattern. + See Note [Desugaring overloaded list patterns] below for more details. + +We expect to add to this list as we deal with more patterns via the expansion +mechanism. + +Note [Desugaring overloaded list patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If OverloadedLists is enabled, we desugar a list pattern to a view pattern: + + [p1, p2, p3] +==> + toList -> [p1, p2, p3] + +This happens directly in the renamer, using the HsPatExpansion mechanism +detailed in Note [Rebindable syntax and HsExpansion]. + +Note that we emit a special view pattern: we additionally keep track of an +inverse to the pattern. +See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details. + +== Wrinkle == + +This is all fine, except in one very specific case: + - when RebindableSyntax is off, + - and the type being matched on is already a list type. + +In this case, it is undesirable to desugar an overloaded list pattern into +a view pattern. To illustrate, consider the following program: + +> {-# LANGUAGE OverloadedLists #-} +> +> f [] = True +> f (_:_) = False + +Without any special logic, the pattern `[]` is desugared to `(toList -> [])`, +whereas `(_:_)` remains a constructor pattern. This implies that the argument +of `f` is necessarily a list (even though `OverloadedLists` is enabled). +After desugaring the overloaded list pattern `[]`, and type-checking, we obtain: + +> f :: [a] -> Bool +> f (toList -> []) = True +> f (_:_) = False + +The pattern match checker then warns that the pattern `[]` is not covered, +as it isn't able to look through view patterns. +We can see that this is silly: as we are matching on a list, `toList` doesn't +actually do anything. So we ignore it, and desugar the pattern to an explicit +list pattern, instead of a view pattern. + +Note however that this is not necessarily sound, because it is possible to have +a list `l` such that `toList l` is not the same as `l`. +This can happen with an overlapping instance, such as the following: + +instance {-# OVERLAPPING #-} IsList [Int] where + type Item [Int] = Int + toList = reverse + fromList = reverse + +We make the assumption that no such instance exists, in order to avoid worsening +pattern-match warnings (see #14547). + ********************************************************* * * External entry points @@ -483,8 +565,11 @@ ; pat' <- rnLPatAndThen mk pat -- Note: at this point the PreTcType in ty can only be a placeHolder -- ; return (ViewPat expr' pat' ty) } - ; return (ViewPat noExtField expr' pat') } + -- Note: we can't cook up an inverse for an arbitrary view pattern, + -- so we pass 'Nothing'. + ; return (ViewPat Nothing expr' pat') } + rnPatAndThen mk (ConPat _ con args) -- rnConPatAndThen takes care of reconstructing the pattern -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. @@ -495,12 +580,25 @@ False -> rnConPatAndThen mk con args rnPatAndThen mk (ListPat _ pats) - = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists + = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists ; pats' <- rnLPatsAndThen mk pats - ; case opt_OverloadedLists of - True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName - ; return (ListPat (Just to_list_name) pats')} - False -> return (ListPat Nothing pats') } + ; if not opt_OverloadedLists + then return (ListPat noExtField pats') + else + -- If OverloadedLists is enabled, desugar to a view pattern. + -- See Note [Desugaring overloaded list patterns] + do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + -- Use 'fromList' as proof of invertibility of the view pattern. + -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn + ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName + ; let + lit_n = mkIntegralLit (length pats) + hs_lit = genHsIntegralLit lit_n + inverse = genHsApps from_list_n_name [hs_lit] + rn_list_pat = ListPat noExtField pats' + exp_expr = genLHsVar to_list_name + exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat) + ; return $ mkExpandedPat rn_list_pat exp_list_pat }} rnPatAndThen mk (TuplePat _ pats boxed) = do { pats' <- rnLPatsAndThen mk pats @@ -547,7 +645,7 @@ unless (scoped_tyvars && type_app) $ case listToMaybe tyargs of Nothing -> pure () - Just tyarg -> addErr $ + Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal visible type application in a pattern:" <+> quotes (char '@' <> ppr tyarg)) 2 (text "Both ScopedTypeVariables and TypeApplications are" @@ -612,6 +710,23 @@ nested_mk (Just (unLoc -> n)) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n)) + +{- ********************************************************************* +* * + Generating code for HsPatExpanded + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +-- | Build a 'HsPatExpansion' out of an extension constructor, +-- and the two components of the expansion: original and +-- desugared patterns +mkExpandedPat + :: Pat GhcRn -- ^ source pattern + -> Pat GhcRn -- ^ expanded pattern + -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion' +mkExpandedPat a b = XPat (HsPatExpanded a b) + {- ************************************************************************ * * @@ -809,25 +924,29 @@ getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds -needFlagDotDot :: HsRecFieldContext -> SDoc -needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, - text "Use RecordWildCards to permit this"] +needFlagDotDot :: HsRecFieldContext -> TcRnMessage +needFlagDotDot ctxt = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Illegal `..' in record" <+> pprRFC ctxt, + text "Use RecordWildCards to permit this"] -badDotDotCon :: Name -> SDoc +badDotDotCon :: Name -> TcRnMessage badDotDotCon con - = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) , nest 2 (text "The constructor has no labelled fields") ] -emptyUpdateErr :: SDoc -emptyUpdateErr = text "Empty record update" +emptyUpdateErr :: TcRnMessage +emptyUpdateErr = TcRnUnknownMessage $ mkPlainError noHints $ text "Empty record update" -badPun :: Located RdrName -> SDoc -badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), - text "Use NamedFieldPuns to permit this"] +badPun :: Located RdrName -> TcRnMessage +badPun fld = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), + text "Use NamedFieldPuns to permit this"] -dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc +dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage dupFieldErr ctxt dups - = hsep [text "duplicate field name", + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "duplicate field name", quotes (ppr (NE.head dups)), text "in record", pprRFC ctxt] @@ -917,10 +1036,12 @@ = (text "Illegal signature in pattern:" <+> ppr ty) $$ nest 4 (text "Use ScopedTypeVariables to permit it") -bogusCharError :: Char -> SDoc +bogusCharError :: Char -> TcRnMessage bogusCharError c - = text "character literal out of range: '\\" <> char c <> char '\'' + = TcRnUnknownMessage $ mkPlainError noHints $ + text "character literal out of range: '\\" <> char c <> char '\'' -badViewPat :: Pat GhcPs -> SDoc -badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, - text "Use ViewPatterns to enable view patterns"] +badViewPat :: Pat GhcPs -> TcRnMessage +badViewPat pat = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Illegal view pattern: " <+> ppr pat, + text "Use ViewPatterns to enable view patterns"] diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -26,6 +26,7 @@ import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) +import GHC.Types.Error import GHC.Types.Basic ( TopLevelFlag, isTopLevel ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable @@ -41,7 +42,7 @@ import GHC.Driver.Session import GHC.Data.FastString -import GHC.Utils.Logger ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger ) +import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName @@ -78,7 +79,7 @@ do { -- Check that -XTemplateHaskellQuotes is enabled and available thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes ; unless thQuotesEnabled $ - failWith ( vcat + failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Syntax error on" <+> ppr e , text ("Perhaps you intended to use TemplateHaskell" ++ " or TemplateHaskellQuotes") ] ) @@ -189,22 +190,23 @@ = hang (text "In the Template Haskell quotation") 2 (ppr br_body) -illegalBracket :: SDoc -illegalBracket = +illegalBracket :: TcRnMessage +illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $ text "Template Haskell brackets cannot be nested" <+> text "(without intervening splices)" -illegalTypedBracket :: SDoc -illegalTypedBracket = +illegalTypedBracket :: TcRnMessage +illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $ text "Typed brackets may only appear in typed splices." -illegalUntypedBracket :: SDoc -illegalUntypedBracket = +illegalUntypedBracket :: TcRnMessage +illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $ text "Untyped brackets may only appear in untyped splices." -quotedNameStageErr :: HsBracket GhcPs -> SDoc +quotedNameStageErr :: HsBracket GhcPs -> TcRnMessage quotedNameStageErr br - = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ text "Stage error: the non-top-level quoted name" <+> ppr br , text "must be used at the same stage at which it is bound" ] @@ -293,7 +295,8 @@ let (herald, ext) = spliceExtension splice extEnabled <- xoptM ext unless extEnabled - (failWith $ text herald <+> text "are not permitted without" <+> ppr ext) + (failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + text herald <+> text "are not permitted without" <+> ppr ext) where spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension) spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) @@ -817,10 +820,8 @@ traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) when is_decl $ do -- Raw material for -dth-dec-file - dflags <- getDynFlags logger <- getLogger - liftIO $ dumpIfSet_dyn_printer alwaysQualify logger dflags Opt_D_th_dec_file - "" FormatHaskell (spliceCodeDoc loc) + liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc) where -- `-ddump-splices` spliceDebugDoc :: SrcSpan -> SDoc @@ -838,11 +839,13 @@ = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -illegalTypedSplice :: SDoc -illegalTypedSplice = text "Typed splices may not appear in untyped brackets" +illegalTypedSplice :: TcRnMessage +illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $ + text "Typed splices may not appear in untyped brackets" -illegalUntypedSplice :: SDoc -illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" +illegalUntypedSplice :: TcRnMessage +illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $ + text "Untyped splices may not appear in typed brackets" checkThLocalName :: Name -> RnM () checkThLocalName name diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -27,6 +27,7 @@ import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) import GHC.Utils.Outputable as Outputable @@ -37,6 +38,7 @@ import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader @@ -101,7 +103,7 @@ ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags err = notInScopeErr (lf_where looking_for) rdr_name $$ extra ; if not show_helpful_errors - then addErr err + then addErr (TcRnUnknownMessage $ mkPlainError noHints err) else do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv ; impInfo <- getImports @@ -110,7 +112,7 @@ ; let suggestions = unknownNameSuggestions_ looking_for dflags hpt currmod global_env local_env impInfo rdr_name - ; addErr (err $$ suggestions) } + ; addErr (TcRnUnknownMessage $ mkPlainError noHints (err $$ suggestions)) } ; return (mkUnboundNameRdr rdr_name) } notInScopeErr :: WhereLooking -> RdrName -> SDoc diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -18,6 +18,8 @@ checkUnusedRecordWildcard, mkFieldEnv, unknownSubordinateErr, badQualBndrErr, typeAppErr, + wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, + genHsIntegralLit, genHsTyLit, HsDocContext(..), pprHsDocContext, inHsDocContext, withHsDocContext, @@ -39,14 +41,17 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad +import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc import GHC.Types.SourceFile +import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc @@ -169,9 +174,11 @@ -- we don't find any GREs that are in scope qualified-only complain [] = return () - complain pp_locs = addDiagnosticAt (WarningWithFlag Opt_WarnNameShadowing) - loc - (shadowedNameWarn occ pp_locs) + complain pp_locs = do + let msg = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnNameShadowing) + noHints + (shadowedNameWarn occ pp_locs) + addDiagnosticAt loc msg is_shadowed_gre :: GlobalRdrElt -> RnM Bool -- Returns False for record selectors that are shadowed, when @@ -199,7 +206,7 @@ let bndrs = sig_ty_bndrs ty in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of Nothing -> return () - Just _ -> addErr $ withHsDocContext ctxt msg + Just _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg) where sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs] sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) @@ -308,7 +315,7 @@ addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () addNoNestedForallsContextsErr ctxt what lty = whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> - addErrAt l $ withHsDocContext ctxt err_msg + addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) {- ************************************************************************ @@ -385,9 +392,12 @@ -- The `..` here doesn't bind any variables as `x` is already bound. warnRedundantRecordWildcard :: RnM () warnRedundantRecordWildcard = - whenWOptM Opt_WarnRedundantRecordWildcards - (addDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) - redundantWildcardWarning) + whenWOptM Opt_WarnRedundantRecordWildcards $ + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) + noHints + redundantWildcardWarning + in addDiagnostic msg -- | Produce a warning when no variables bound by a `..` pattern are used. @@ -404,7 +414,7 @@ warnUnusedRecordWildcard ns used_names = do let used = filter (`elemNameSet` used_names) ns traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) - warnIfFlag Opt_WarnUnusedRecordWildcards (null used) + warnIf (null used) unusedRecordWildcardWarning @@ -474,15 +484,17 @@ | otherwise = not (startsWithUnderscore (occName child)) addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg - = addDiagnosticAt (WarningWithFlag flag) span $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] +addUnusedWarning flag occ span msg = do + let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace occ) + <+> quotes (ppr occ)] + addDiagnosticAt span diag -unusedRecordWildcardWarning :: SDoc +unusedRecordWildcardWarning :: TcRnMessage unusedRecordWildcardWarning = - wildcardDoc $ text "No variables bound in the record wildcard match are used" + TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ + wildcardDoc $ text "No variables bound in the record wildcard match are used" redundantWildcardWarning :: SDoc redundantWildcardWarning = @@ -531,7 +543,8 @@ -- already, and we don't want an error cascade. = return () | otherwise - = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) , text "It could refer to" , nest 3 (vcat (msg1 : msgs)) ]) where @@ -593,7 +606,7 @@ dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () dupNamesErr get_loc names - = addErrAt big_loc $ + = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), locations] where @@ -601,13 +614,15 @@ big_loc = foldr1 combineSrcSpans locs locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs)) -badQualBndrErr :: RdrName -> SDoc +badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name - = text "Qualified name in binding position:" <+> ppr rdr_name + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Qualified name in binding position:" <+> ppr rdr_name -typeAppErr :: String -> LHsType GhcPs -> SDoc +typeAppErr :: String -> LHsType GhcPs -> TcRnMessage typeAppErr what (L _ k) - = hang (text "Illegal visible" <+> text what <+> text "application" + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal visible" <+> text what <+> text "application" <+> quotes (char '@' <> ppr k)) 2 (text "Perhaps you intended to use TypeApplications") @@ -618,9 +633,10 @@ | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr (sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")]) + nest 2 (text "Workaround: use nested tuples or define a data type")] -- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'. checkCTupSize :: Int -> TcM () @@ -628,10 +644,43 @@ | tup_size <= mAX_CTUPLE_SIZE = return () | otherwise - = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Constraint tuple arity too large:" <+> int tup_size <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple")) + 2 (text "Instead, use a nested tuple") +{- ********************************************************************* +* * + Generating code for HsExpanded + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +wrapGenSpan :: a -> LocatedAn an a +-- Wrap something in a "generatedSrcSpan" +-- See Note [Rebindable syntax and HsExpansion] +wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x + +genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsApps fun args = foldl genHsApp (genHsVar fun) args + +genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn +genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg + +genLHsVar :: Name -> LHsExpr GhcRn +genLHsVar nm = wrapGenSpan $ genHsVar nm + +genHsVar :: Name -> HsExpr GhcRn +genHsVar nm = HsVar noExtField $ wrapGenSpan nm + +genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn +genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan + +genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) +genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) + +genHsTyLit :: FastString -> HsType GhcRn +genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText {- ************************************************************************ diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -38,6 +38,7 @@ import GHC.Utils.Logger import GHC.Types.Id +import GHC.Types.Id.Make (ghcPrimIds) import GHC.Types.Name import GHC.Types.Var hiding ( varName ) import GHC.Types.Var.Set @@ -47,7 +48,7 @@ import Control.Monad import Control.Monad.Catch as MC -import Data.List ( (\\) ) +import Data.List ( (\\), partition ) import Data.Maybe import Data.IORef @@ -60,25 +61,45 @@ mapM (\w -> GHC.parseName w >>= mapM GHC.lookupName) (words str) - let ids = [id | AnId id <- tythings] + -- Sort out good and bad tythings for :print and friends + let (pprintables, unpprintables) = partition can_pprint tythings + -- Obtain the terms and the recovered type information + let ids = [id | AnId id <- pprintables] (subst, terms) <- mapAccumLM go emptyTCvSubst ids -- Apply the substitutions obtained after recovering the types modifySession $ \hsc_env -> hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} - -- Finally, print the Terms - unqual <- GHC.getPrintUnqual + -- Finally, print the Results docterms <- mapM showTerm terms - dflags <- getDynFlags - logger <- getLogger - liftIO $ (printOutputForUser logger dflags unqual . vcat) - (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) - ids - docterms) + let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) + ids + docterms + printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms where + -- Check whether a TyThing can be processed by :print and friends. + -- Take only Ids, exclude pseudoops, they don't have any HValues. + can_pprint :: TyThing -> Bool -- #19394 + can_pprint (AnId x) + | x `notElem` ghcPrimIds = True + | otherwise = False + can_pprint _ = False + + -- Create a short message for a TyThing, that cannot processed by :print + no_pprint :: TyThing -> SDoc + no_pprint tything = ppr tything <+> + text "is not eligible for the :print, :sprint or :force commands." + + -- Helper to print out the results of :print and friends + printSDocs :: GhcMonad m => [SDoc] -> m () + printSDocs sdocs = do + logger <- getLogger + unqual <- GHC.getPrintUnqual + liftIO $ printOutputForUser logger unqual $ vcat sdocs + -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) go subst id = do @@ -96,10 +117,9 @@ hsc_env <- getSession case (improveRTTIType hsc_env id_ty' reconstructed_type) of Nothing -> return (subst, term') - Just subst' -> do { dflags <- GHC.getSessionDynFlags - ; logger <- getLogger + Just subst' -> do { logger <- getLogger ; liftIO $ - dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" + putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" FormatText (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, 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 @@ -93,6 +93,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Utils.Trace import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -578,7 +579,7 @@ mb_hValues <- mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $ + debugTraceMsg (hsc_logger hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time @@ -668,9 +669,8 @@ warnPprTrace True (text (":print failed to calculate the " ++ "improvement for a type")) hsc_env Just subst -> do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" + putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" FormatText (fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]) @@ -1275,13 +1275,13 @@ obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do - hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) + hv <- Loader.loadName (hscInterp hsc_env) hsc_env Nothing (varName id) cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) + hv <- Loader.loadName (hscInterp hsc_env) hsc_env Nothing (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -517,10 +517,7 @@ -} --- A (non-mutable) tau type containing --- existentially quantified tyvars. --- (since GHC type language currently does not support --- existentials, we leave these variables unquantified) +-- See Note [RttiType] type RttiType = Type -- An incomplete type as stored in GHCi: @@ -571,6 +568,37 @@ newOpenVar = liftTcM (do { kind <- newOpenTypeKind ; newVar kind }) +{- Note [RttiType] +~~~~~~~~~~~~~~~~~~ +The type synonym `type RttiType = Type` is the type synonym used +by the debugger for the types of the data type `Term`. + +For a long time the `RttiType` carried the following comment: + +> A (non-mutable) tau type containing +> existentially quantified tyvars. +> (since GHC type language currently does not support +> existentials, we leave these variables unquantified) + +The tau type part is only correct for terms representing the results +of fully saturated functions that return non-function (data) values +and not functions. + +For non-function values, the GHC runtime always works with concrete +types eg `[Maybe Int]`, but never with polymorphic types like eg +`(Traversable t, Monad m) => t (m a)`. The concrete types, don't +need a quantification. They are always tau types. + +The debugger binds the terms of :print commands and of the free +variables at a breakpoint to names. These newly bound names can +be used in new GHCi expressions. If these names represent functions, +then the type checker expects that the types of these functions are +fully-fledged. They must contain the necessary `forall`s and type +constraints. Hence the types of terms that represent functions must +be sigmas and not taus. +(See #12449) +-} + {- Note [RuntimeUnkTv] ~~~~~~~~~~~~~~~~~~~~~~ In the GHCi debugger we use unification variables whose MetaInfo is @@ -700,11 +728,11 @@ else do (old_ty', rev_subst) <- instScheme quant_old_ty my_ty <- newOpenVar - when (check1 quant_old_ty) (traceTR (text "check1 passed") >> + when (check1 old_tvs) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty old_ty hval new_ty <- zonkTcType (termType term) - if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty + if isMonomorphic new_ty || check2 new_ty old_ty then do traceTR (text "check2 passed") addConstraint new_ty old_ty' @@ -974,14 +1002,14 @@ else do (old_ty', rev_subst) <- instScheme sigma_old_ty my_ty <- newOpenVar - when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> + when (check1 old_tvs) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') search (isMonomorphic `fmap` zonkTcType my_ty) (\(ty,a) -> go ty a) (Seq.singleton (my_ty, hval)) max_depth new_ty <- zonkTcType my_ty - if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty + if isMonomorphic new_ty || check2 new_ty old_ty then do traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) addConstraint my_ty old_ty' @@ -1232,21 +1260,37 @@ -} -check1 :: QuantifiedType -> Bool -check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) +check1 :: [TyVar] -> Bool +check1 tvs = not $ any isHigherKind (map tyVarKind tvs) where isHigherKind = not . null . fst . splitPiTys -check2 :: QuantifiedType -> QuantifiedType -> Bool -check2 (_, rtti_ty) (_, old_ty) - | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty - = case () of - _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty - -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) - _ | Just _ <- splitAppTy_maybe old_ty - -> isMonomorphicOnNonPhantomArgs rtti_ty - _ -> True - | otherwise = True +check2 :: Type -> Type -> Bool +check2 rtti_ty old_ty = check2' (tauPart rtti_ty) (tauPart old_ty) + -- The function `tcSplitTyConApp_maybe` doesn't split foralls or types + -- headed with (=>). Hence here we need only the tau part of a type. + -- See Note [Missing test case]. + where + check2' rtti_ty old_ty + | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty + = case () of + _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty + -> and$ zipWith check2 rttis olds + _ | Just _ <- splitAppTy_maybe old_ty + -> isMonomorphicOnNonPhantomArgs rtti_ty + _ -> True + | otherwise = True + tauPart ty = tau + where + (_, _, tau) = tcSplitNestedSigmaTys ty +{- +Note [Missing test case] +~~~~~~~~~~~~~~~~~~~~~~~~ +Her we miss a test case. It should be a term, with a function `f` +with a non-empty sigma part and an unsound type. The result of +`check2 f` should be different if we omit or do the calls to `tauPart`. +I (R.Senn) was unable to find such a term, and I'm in doubt, whether it exists. +-} -- Dealing with newtypes -------------------------- diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -63,20 +63,21 @@ import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) +import GHC.Unit.Types (ModuleNameWithIsBoot) -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes. -initializePlugins :: HscEnv -> IO HscEnv -initializePlugins hsc_env +initializePlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO HscEnv +initializePlugins hsc_env mnwib -- plugins not changed | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags -- arguments not changed , all same_args (hsc_plugins hsc_env) = return hsc_env -- no need to reload plugins | otherwise - = do loaded_plugins <- loadPlugins hsc_env + = do loaded_plugins <- loadPlugins hsc_env mnwib let hsc_env' = hsc_env { hsc_plugins = loaded_plugins } withPlugins hsc_env' driverPlugin hsc_env' where @@ -85,8 +86,8 @@ argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) dflags = hsc_dflags hsc_env -loadPlugins :: HscEnv -> IO [LoadedPlugin] -loadPlugins hsc_env +loadPlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO [LoadedPlugin] +loadPlugins hsc_env mnwib = do { unless (null to_load) $ checkExternalInterpreter hsc_env ; plugins <- mapM loadPlugin to_load @@ -100,14 +101,14 @@ where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] - loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env + loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env mnwib loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin loadFrontendPlugin hsc_env mod_name = do checkExternalInterpreter hsc_env fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName - hsc_env mod_name + hsc_env Nothing mod_name -- #14335 checkExternalInterpreter :: HscEnv -> IO () @@ -116,8 +117,8 @@ -> throwIO (InstallationError "Plugins require -fno-external-interpreter") _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) -loadPlugin' occ_name plugin_name hsc_env mod_name +loadPlugin' :: OccName -> Name -> HscEnv -> Maybe ModuleNameWithIsBoot -> ModuleName -> IO (a, ModIface) +loadPlugin' occ_name plugin_name hsc_env mnwib mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name @@ -131,7 +132,7 @@ Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; mb_plugin <- getValueSafely hsc_env mnwib name (mkTyConTy plugin_tycon) ; case mb_plugin of Nothing -> throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep @@ -183,24 +184,23 @@ -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) -getValueSafely hsc_env val_name expected_type = do +getValueSafely :: HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env mnwib val_name expected_type = do mb_hval <- case getValueSafelyHook hooks of - Nothing -> getHValueSafely interp hsc_env val_name expected_type - Just h -> h hsc_env val_name expected_type + Nothing -> getHValueSafely interp hsc_env mnwib val_name expected_type + Just h -> h hsc_env mnwib val_name expected_type case mb_hval of Nothing -> return Nothing Just hval -> do - value <- lessUnsafeCoerce logger dflags "getValueSafely" hval + value <- lessUnsafeCoerce logger "getValueSafely" hval return (Just value) where interp = hscInterp hsc_env - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue) -getHValueSafely interp hsc_env val_name expected_type = do +getHValueSafely :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe HValue) +getHValueSafely interp hsc_env mnwib val_name expected_type = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupType hsc_env val_name @@ -213,12 +213,12 @@ then do -- Link in the module that contains the value, if it has such a module case nameModule_maybe val_name of - Just mod -> do loadModule interp hsc_env mod + Just mod -> do loadModule interp hsc_env mnwib mod return () Nothing -> return () -- Find the value that we just linked in and cast it given that we have proved it's type hval <- do - v <- loadName interp hsc_env val_name + v <- loadName interp hsc_env mnwib val_name wormhole interp v return (Just hval) else return Nothing @@ -231,12 +231,12 @@ -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened -- if it /does/ segfault -lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b -lessUnsafeCoerce logger dflags context what = do - debugTraceMsg logger dflags 3 $ +lessUnsafeCoerce :: Logger -> String -> a -> IO b +lessUnsafeCoerce logger context what = do + debugTraceMsg logger 3 $ (text "Coercing a value in") <+> (text context) <> (text "...") output <- evaluate (unsafeCoerce what) - debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion") + debugTraceMsg logger 3 (text "Successfully evaluated coercion") return output diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -19,7 +19,7 @@ import Control.Monad (when) import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import GHC.Utils.Monad.State.Strict import Control.Monad.Trans.Class import GHC.Types.Unique.Map import GHC.Types.SrcLoc diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -115,9 +115,6 @@ type instance XLet 'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton -freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet -freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] -freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs -- | Captures details of the syntax tree relevant to the cost model, such as -- closures, multi-shot lambdas and case expressions. diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -42,24 +42,31 @@ import GHC.Stg.Syntax import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic + import GHC.Core.Lint ( interactiveInScope ) -import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +import GHC.Core.DataCon +import GHC.Core ( AltCon(..) ) +import GHC.Core.Type + import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Id import GHC.Types.Var.Set -import GHC.Core.DataCon -import GHC.Core ( AltCon(..) ) import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) -import GHC.Utils.Error ( mkLocMessage ) -import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc + import GHC.Utils.Logger import GHC.Utils.Outputable +import GHC.Utils.Error ( mkLocMessage, DiagOpts ) +import qualified GHC.Utils.Error as Err + import GHC.Unit.Module ( Module ) import GHC.Runtime.Context ( InteractiveContext ) -import qualified GHC.Utils.Error as Err + +import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) + import Control.Applicative ((<|>)) import Control.Monad @@ -75,11 +82,11 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} - case initL dflags this_mod unarised opts top_level_binds (lint_binds binds) of + case initL diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> return () Just msg -> do - putLogMsg logger dflags Err.MCDump noSrcSpan + logMsg logger Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", @@ -87,8 +94,9 @@ text "*** Offending Program ***", pprGenStgTopBindings opts binds, text "*** End of Offense ***"]) - Err.ghcExit logger dflags 1 + Err.ghcExit logger 1 where + diag_opts = initDiagOpts dflags opts = initStgPprOpts dflags -- Bring all top-level binds into scope because CoreToStg does not generate -- bindings in dependency order (so we may see a use before its definition). @@ -247,7 +255,7 @@ newtype LintM a = LintM { unLintM :: Module -> LintFlags - -> DynFlags + -> DiagOpts -- Diagnostic options -> StgPprOpts -- Pretty-printing options -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope @@ -282,9 +290,9 @@ pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -initL :: DynFlags -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc -initL dflags this_mod unarised opts locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised) dflags opts [] locals emptyBag +initL :: DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc +initL diag_opts this_mod unarised opts locals (LintM m) = do + let (_, errs) = m this_mod (LintFlags unarised) diag_opts opts [] locals emptyBag if isEmptyBag errs then Nothing else @@ -300,14 +308,14 @@ (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf dflags opts loc scope errs - -> case unLintM m mod lf dflags opts loc scope errs of - (r, errs') -> unLintM (k r) mod lf dflags opts loc scope errs' +thenL m k = LintM $ \mod lf diag_opts opts loc scope errs + -> case unLintM m mod lf diag_opts opts loc scope errs of + (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf dflags opts loc scope errs - -> case unLintM m mod lf dflags opts loc scope errs of - (_, errs') -> unLintM k mod lf dflags opts loc scope errs' +thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs + -> case unLintM m mod lf diag_opts opts loc scope errs of + (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -354,24 +362,24 @@ addErrL :: SDoc -> LintM () addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) -addErr :: DynFlags -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc -addErr dflags errs_so_far msg locs +addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc +addErr diag_opts errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage (Err.mkMCDiagnostic dflags WarningWithoutFlag) + in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag) l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf dflags opts loc scope errs - -> unLintM m mod lf dflags opts (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs + -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf dflags opts loc scope errs +addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs -> let new_set = mkVarSet ids - in unLintM m mod lf dflags opts loc (scope `unionVarSet` new_set) errs + in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) @@ -380,10 +388,10 @@ getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf dflags _opts loc scope errs +checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then - ((), addErr dflags errs (hsep [ppr id, dcolon, ppr (idType id), - text "is out of scope"]) loc) + ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id), + text "is out of scope"]) loc) else ((), errs) diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -28,23 +28,22 @@ import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader -newtype StgM a = StgM { _unStgM :: StateT Char IO a } +newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } deriving (Functor, Applicative, Monad, MonadIO) instance MonadUnique StgM where - getUniqueSupplyM = StgM $ do { mask <- get + getUniqueSupplyM = StgM $ do { mask <- ask ; liftIO $! mkSplitUniqSupply mask} - getUniqueM = StgM $ do { mask <- get + getUniqueM = StgM $ do { mask <- ask ; liftIO $! uniqFromMask mask} runStgM :: Char -> StgM a -> IO a -runStgM mask (StgM m) = evalStateT m mask +runStgM mask (StgM m) = runReaderT m mask stg2stg :: Logger -> DynFlags -- includes spec of what stg-to-stg passes to do @@ -54,7 +53,7 @@ -> IO [StgTopBinding] -- output program stg2stg logger dflags ictxt this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds - ; showPass logger dflags "Stg2Stg" + ; showPass logger "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) @@ -86,7 +85,7 @@ return binds StgStats -> - trace (showStgStats binds) (return binds) + logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds) StgCSE -> do let binds' = {-# SCC "StgCse" #-} stgCse binds @@ -107,11 +106,11 @@ opts = initStgPprOpts dflags dump_when flag header binds - = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds) + = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings opts binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required - dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what + putDumpFileMaybe logger Opt_D_verbose_stg2stg what FormatSTG (vcat (map (pprStgTopBinding opts) binds2)) stg_linter False what binds2 return binds2 diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -6,13 +6,12 @@ import GHC.Types.Id import GHC.Types.Var.Env -import Control.Monad.Trans.State.Strict +import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic - -import GHC.Driver.Ppr +import GHC.Utils.Trace -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -231,7 +231,7 @@ This means that it's safe to wrap `StgArg`s of DataCon applications with `GHC.StgToCmm.Env.NonVoid`, for example. - * Similar to unboxed tuples, Note [Rubbish values] of TupleRep may only + * Similar to unboxed tuples, Note [Rubbish literals] of TupleRep may only appear in return position. * Alt binders (binders in patterns) are always non-void. @@ -390,7 +390,7 @@ , Just args' <- unariseMulti_maybe rho dc args ty_args = elimCase rho args' bndr alt_ty alts - -- See (3) of Note [Rubbish values] in GHC.Types.Literal + -- See (3) of Note [Rubbish literals] in GHC.Types.Literal | StgLit lit <- scrut , Just args' <- unariseRubbish_maybe lit = elimCase rho args' bndr alt_ty alts @@ -427,19 +427,18 @@ -- Doesn't return void args. unariseRubbish_maybe :: Literal -> Maybe [OutStgArg] -unariseRubbish_maybe lit - | LitRubbish preps <- lit - , [prep] <- preps +unariseRubbish_maybe (LitRubbish rep) + | [prep] <- preps , not (isVoidRep prep) - -- Single, non-void PrimRep. Nothing to do! - = Nothing + = Nothing -- Single, non-void PrimRep. Nothing to do! - | LitRubbish preps <- lit - -- Multiple reps, possibly with VoidRep. Eliminate! - = Just [ StgLitArg (LitRubbish [prep]) | prep <- preps, not (isVoidRep prep) ] + | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + = Just [ StgLitArg (LitRubbish (primRepToType prep)) + | prep <- preps, not (isVoidRep prep) ] + where + preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep - | otherwise - = Nothing +unariseRubbish_maybe _ = Nothing -------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -104,7 +104,7 @@ -> Maybe ModBreaks -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming logger dflags + = withTiming logger (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- Split top-level binds into strings and others. @@ -129,7 +129,7 @@ when (notNull ffis) (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?") - dumpIfSet_dyn logger dflags Opt_D_dump_BCOs + putDumpFileMaybe logger Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -148,8 +148,8 @@ return cbc - where dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env + where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env interp = hscInterp hsc_env profile = targetProfile dflags @@ -186,7 +186,7 @@ -> StgRhs -> IO UnlinkedBCO stgExprToBCOs hsc_env this_mod expr_ty expr - = withTiming logger dflags + = withTiming logger (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do @@ -205,12 +205,12 @@ when (notNull mallocd) (panic "GHC.StgToByteCode.stgExprToBCOs: missing final emitBc?") - dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + putDumpFileMaybe logger Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (ppr proto_bco) assembleOneBCO interp profile proto_bco - where dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env + where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env profile = targetProfile dflags interp = hscInterp hsc_env -- we need an otherwise unused Id for bytecode generation @@ -567,10 +567,8 @@ -- The code that constructs the thunk, and the code that executes -- it, have to agree about this layout -fvsToEnv p (StgRhsClosure fvs _ _ _ _) = - [v | v <- dVarSetElems fvs, - v `Map.member` p] -fvsToEnv _ _ = [] +fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs, + v `Map.member` p] -- ----------------------------------------------------------------------------- -- schemeE @@ -777,18 +775,19 @@ in tail position. See Note [Join points] and Note [Invariants on join points], both in GHC.Core. Because join points do not compile to true, red-blooded variables (with, e.g., registers allocated to them), they are allowed -to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points] -in GHC.Core.) +to be representation-polymorphic. +(See invariant #6 in Note [Invariants on join points] in GHC.Core.) However, in this byte-code generator, join points *are* treated just as ordinary variables. There is no check whether a binding is for a join point or not; they are all treated uniformly. (Perhaps there is a missed optimization opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) -We thus must have *some* strategy for dealing with levity-polymorphic and -unlifted join points. Levity-polymorphic variables are generally not allowed -(though levity-polymorphic join points *are*; see Note [Invariants on join points] -in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly. +We thus must have *some* strategy for dealing with representation-polymorphic +and unlifted join points. Representation-polymorphic variables are generally +not allowed (though representation -polymorphic join points *are*; see +Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to +evaluate unlifted join points eagerly. The questionable join points are *not-necessarily-lifted join points* (NNLJPs). (Not having such a strategy led to #16509, which panicked in the isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy: @@ -797,9 +796,9 @@ 2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the type to tack on a `(# #) ->`. - Note that functions are never levity-polymorphic, so this transformation - changes an NNLJP to a non-levity-polymorphic join point. This is done - in bcPrepSingleBind. + Note that functions are never representation-polymorphic, so this + transformation changes an NNLJP to a non-representation-polymorphic + join point. This is done in bcPrepSingleBind. 3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId), being careful to note the new type of the NNLJP. This is done in the AnnVar diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -98,7 +98,7 @@ ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s) ; let cg :: FCode a -> Stream IO CmmGroup a cg fcode = do - (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do + (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do CodeGenState ts st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -15,6 +15,14 @@ import GHC.Prelude hiding ((<*>)) +import GHC.Driver.Session + +import GHC.Core ( AltCon(..) ) +import GHC.Runtime.Heap.Layout +import GHC.Unit.Module + +import GHC.Stg.Syntax + import GHC.Platform import GHC.Platform.Profile @@ -32,29 +40,26 @@ import GHC.StgToCmm.Foreign (emitPrimCall) import GHC.Cmm.Graph -import GHC.Core ( AltCon(..) ) import GHC.Cmm.BlockId -import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.Utils import GHC.Cmm.CLabel -import GHC.Stg.Syntax + import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Unit.Module -import GHC.Data.List.SetOps -import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish ( tickishIsCode ) + +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic + import GHC.Data.FastString -import GHC.Driver.Session -import GHC.Driver.Ppr +import GHC.Data.List.SetOps import Control.Monad @@ -764,9 +769,10 @@ -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.hs with a description generated from the data constructor closureDescription dflags mod_name name - = showSDocDump (initSDocContext dflags defaultDumpStyle) (char '<' <> + = let ctx = initSDocContext dflags defaultDumpStyle + -- defaultDumpStyle, because we want to see the unique on the Name. + in renderWithContext ctx (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <> char '>') - -- showSDocDump, because we want to see the unique on the Name. 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 @@ -84,6 +84,7 @@ arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg) (platformWordSizeInBytes platform) ; cmm_args <- getFCallArgs stg_args typ + -- ; traceM $ show cmm_args ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs --- a/compiler/GHC/StgToCmm/Lit.hs +++ b/compiler/GHC/StgToCmm/Lit.hs @@ -23,6 +23,7 @@ import GHC.Cmm.Utils import GHC.Types.Literal +import GHC.Types.RepType( runtimeRepPrimRep ) import GHC.Builtin.Types ( unitDataConId ) import GHC.Core.TyCon import GHC.Utils.Misc @@ -49,8 +50,8 @@ cgLit (LitString s) = CmmLit <$> newByteStringCLit s -- not unpackFS; we want the UTF-8 byte stream. -cgLit (LitRubbish preps) = - case expectOnly "cgLit:Rubbish" preps of -- Note [Post-unarisation invariants] +cgLit (LitRubbish rep) = + case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] VoidRep -> panic "cgLit:VoidRep" -- dito LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId @@ -60,7 +61,9 @@ let elem_lit = mkSimpleLit platform (num_rep_lit (primElemRepToPrimRep elem)) pure (CmmLit (CmmVec (replicate n elem_lit))) prep -> cgLit (num_rep_lit prep) - where + where + prim_reps = runtimeRepPrimRep (text "cgLit") rep + num_rep_lit IntRep = mkLitIntUnchecked 0 num_rep_lit Int8Rep = mkLitInt8Unchecked 0 num_rep_lit Int16Rep = mkLitInt16Unchecked 0 @@ -74,6 +77,7 @@ num_rep_lit FloatRep = LitFloat 0 num_rep_lit DoubleRep = LitDouble 0 num_rep_lit other = pprPanic "num_rep_lit: Not a num lit" (ppr other) + cgLit other_lit = do platform <- getPlatform pure (CmmLit (mkSimpleLit platform other_lit)) 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 @@ -2738,7 +2738,7 @@ dst_off <- assignTempE dst_off0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW profile) dst dst_off n + emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) @@ -2804,7 +2804,7 @@ dst <- assignTempE dst0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW profile) dst dst_off n + emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) @@ -3165,7 +3165,7 @@ -- | Push a range of pointer-array elements that are about to be copied over to -- the update remembered set. emitCopyUpdRemSetPush :: Platform - -> WordOff -- ^ array header size + -> ByteOff -- ^ array header size (in bytes) -> CmmExpr -- ^ destination array -> CmmExpr -- ^ offset in destination array (in words) -> Int -- ^ number of elements to copy diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -102,6 +102,8 @@ import GHC.Prelude +import GHC.Driver.Session + import GHC.Platform import GHC.Platform.Profile @@ -126,9 +128,6 @@ import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Driver.Session -import GHC.Driver.Ppr - -- Turgid imports for showTypeCategory import GHC.Builtin.Names import GHC.Tc.Utils.TcType @@ -243,7 +242,9 @@ then n <+> parens (ppr mod_name) <+> ext <+> p else n <+> ext <+> p - ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name + ; let ctx = (initSDocContext dflags defaultDumpStyle) + { sdocPprDebug = True } + ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args ; emitDataLits ctr_lbl -- Must match layout of includes/rts/Ticky.h's StgEntCounter diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -18,7 +18,6 @@ import GHC.Utils.Asm import GHC.Utils.Exception -import GHC.Driver.Session import GHC.Platform import GHC.Utils.Error import GHC.Data.Maybe (MaybeT(..),runMaybeT) @@ -142,9 +141,9 @@ -- | Read the ELF header -readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfHeader :: Logger -> ByteString -> IO (Maybe ElfHeader) +readElfHeader logger bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF header") return Nothing where @@ -196,13 +195,12 @@ -- | Read the ELF section table readElfSectionTable :: Logger - -> DynFlags -> ElfHeader -> ByteString -> IO (Maybe SectionTable) -readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfSectionTable logger hdr bs = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF section table") return Nothing where @@ -248,15 +246,14 @@ -- | Read a ELF section readElfSectionByIndex :: Logger - -> DynFlags -> ElfHeader -> SectionTable -> Word64 -> ByteString -> IO (Maybe Section) -readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfSectionByIndex logger hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF section") return Nothing where @@ -293,13 +290,12 @@ -- -- We do not perform any check on the section type. findSectionFromName :: Logger - -> DynFlags -> ElfHeader -> SectionTable -> String -> ByteString -> IO (Maybe ByteString) -findSectionFromName logger dflags hdr secTable name bs = +findSectionFromName logger hdr secTable name bs = rec [0..sectionEntryCount secTable - 1] where -- convert the required section name into a ByteString to perform @@ -310,7 +306,7 @@ -- the matching one, if any rec [] = return Nothing rec (x:xs) = do - me <- readElfSectionByIndex logger dflags hdr secTable x bs + me <- readElfSectionByIndex logger hdr secTable x bs case me of Just e | entryName e == name' -> return (Just (entryBS e)) _ -> rec xs @@ -321,20 +317,19 @@ -- If the section isn't found or if there is any parsing error, we return -- Nothing readElfSectionByName :: Logger - -> DynFlags -> ByteString -> String -> IO (Maybe LBS.ByteString) -readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfSectionByName logger bs name = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF section \"" ++ name ++ "\"") return Nothing where action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader logger dflags bs - secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs - MaybeT $ findSectionFromName logger dflags hdr secTable name bs + hdr <- MaybeT $ readElfHeader logger bs + secTable <- MaybeT $ readElfSectionTable logger hdr bs + MaybeT $ findSectionFromName logger hdr secTable name bs ------------------ -- NOTE SECTIONS @@ -345,14 +340,13 @@ -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteBS :: Logger - -> DynFlags -> ByteString -> String -> String -> IO (Maybe LBS.ByteString) -readElfNoteBS logger dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfNoteBS logger bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing @@ -386,8 +380,8 @@ action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader logger dflags bs - sec <- MaybeT $ readElfSectionByName logger dflags bs sectionName + hdr <- MaybeT $ readElfHeader logger bs + sec <- MaybeT $ readElfSectionByName logger bs sectionName MaybeT $ runGetOrThrow (findNote hdr) sec -- | read a Note as a String @@ -395,21 +389,20 @@ -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteAsString :: Logger - -> DynFlags -> FilePath -> String -> String -> IO (Maybe String) -readElfNoteAsString logger dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfNoteAsString logger path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing where action = do bs <- LBS.readFile path - note <- readElfNoteBS logger dflags bs sectionName noteId + note <- readElfNoteBS logger bs sectionName noteId return (fmap B8.unpack note) diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -195,10 +195,10 @@ parseLinkerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Error (figuring out linker information):" <+> text (show err)) - errorMsg logger dflags $ hang (text "Warning:") 9 $ + errorMsg logger $ hang (text "Warning:") 9 $ text "Couldn't figure out linker information!" $$ text "Make sure you're using GNU ld, GNU gold" <+> text "or the built in OS X linker, etc." @@ -213,7 +213,7 @@ Just v -> return v Nothing -> do let pgm = pgm_c dflags - v <- getCompilerInfo' logger dflags pgm + v <- getCompilerInfo' logger pgm writeIORef (rtccInfo dflags) (Just v) return v @@ -225,13 +225,13 @@ Just v -> return v Nothing -> do let (pgm, _) = pgm_a dflags - v <- getCompilerInfo' logger dflags pgm + v <- getCompilerInfo' logger pgm writeIORef (rtasmInfo dflags) (Just v) return v -- See Note [Run-time linker info]. -getCompilerInfo' :: Logger -> DynFlags -> String -> IO CompilerInfo -getCompilerInfo' logger dflags pgm = do +getCompilerInfo' :: Logger -> String -> IO CompilerInfo +getCompilerInfo' logger pgm = do let -- Try to grab the info from the process output. parseCompilerInfo _stdo stde _exitc -- Regular GCC @@ -264,10 +264,10 @@ parseCompilerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Error (figuring out C compiler information):" <+> text (show err)) - errorMsg logger dflags $ hang (text "Warning:") 9 $ + errorMsg logger $ hang (text "Warning:") 9 $ text "Couldn't figure out C compiler information!" $$ text "Make sure you're using GNU gcc, or clang" return UnknownCC diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -131,7 +131,6 @@ -- Running an external program runSomething :: Logger - -> DynFlags -> String -- For -v message -> String -- Command name (possibly a full path) -- assumed already dos-ified @@ -139,8 +138,8 @@ -- runSomething will dos-ify them -> IO () -runSomething logger dflags phase_name pgm args = - runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing +runSomething logger phase_name pgm args = + runSomethingFiltered logger id phase_name pgm args Nothing Nothing -- | Run a command, placing the arguments in an external response file. -- @@ -162,10 +161,10 @@ -> Maybe [(String,String)] -> IO () runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env = - runSomethingWith logger dflags phase_name pgm args $ \real_args -> do + runSomethingWith logger phase_name pgm args $ \real_args -> do fp <- getResponseFile real_args let args = ['@':fp] - r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env + r <- builderMainLoop logger filter_fn pgm args Nothing mb_env return (r,()) where getResponseFile args = do @@ -205,23 +204,23 @@ ] runSomethingFiltered - :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] + :: Logger -> (String->String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env = - runSomethingWith logger dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env +runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env = + runSomethingWith logger phase_name pgm args $ \real_args -> do + r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env return (r,()) runSomethingWith - :: Logger -> DynFlags -> String -> String -> [Option] + :: Logger -> String -> String -> [Option] -> ([String] -> IO (ExitCode, a)) -> IO a -runSomethingWith logger dflags phase_name pgm args io = do +runSomethingWith logger phase_name pgm args io = do let real_args = filter notNull (map showOpt args) cmdLine = showCommandForUser pgm real_args - traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do @@ -241,10 +240,10 @@ does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) -builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath +builderMainLoop :: Logger -> (String -> String) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode -builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do +builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do chan <- newChan -- We use a mask here rather than a bracket because we want @@ -305,10 +304,10 @@ msg <- readChan chan case msg of BuildMsg msg -> do - logInfo logger dflags $ withPprStyle defaultUserStyle msg + logInfo logger $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do - putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc) + logMsg logger errorDiagnostic (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> 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 @@ -14,7 +14,7 @@ import GHC.ForeignSrcLang import GHC.IO (catchException) -import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionMin, supportedLlvmVersionMax, llvmVersionStr, parseLlvmVersion) +import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion) import GHC.SysTools.Process import GHC.SysTools.Info @@ -42,31 +42,31 @@ -} runUnlit :: Logger -> DynFlags -> [Option] -> IO () -runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do +runUnlit logger dflags args = traceToolCommand logger "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L - runSomething logger dflags "Literate pre-processor" prog + runSomething logger "Literate pre-processor" prog (map Option opts ++ args) runCpp :: Logger -> DynFlags -> [Option] -> IO () -runCpp logger dflags args = traceToolCommand logger dflags "cpp" $ do +runCpp logger dflags args = traceToolCommand logger "cpp" $ do let (p,args0) = pgm_P dflags args1 = map Option (getOpts dflags opt_P) args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] mb_env <- getGccEnv args2 - runSomethingFiltered logger dflags id "C pre-processor" p + runSomethingFiltered logger id "C pre-processor" p (args0 ++ args1 ++ args2 ++ args) Nothing mb_env runPp :: Logger -> DynFlags -> [Option] -> IO () -runPp logger dflags args = traceToolCommand logger dflags "pp" $ do +runPp logger dflags args = traceToolCommand logger "pp" $ do let prog = pgm_F dflags opts = map Option (getOpts dflags opt_F) - runSomething logger dflags "Haskell pre-processor" prog (args ++ opts) + runSomething logger "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceToolCommand logger dflags "cc" $ do +runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do let p = pgm_c dflags args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 @@ -148,43 +148,43 @@ -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceToolCommand logger dflags "linker" $ do +askLd logger dflags args = traceToolCommand logger "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingWith logger dflags "gcc" p args2 $ \real_args -> + runSomethingWith logger "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } runAs :: Logger -> DynFlags -> [Option] -> IO () -runAs logger dflags args = traceToolCommand logger dflags "as" $ do +runAs logger dflags args = traceToolCommand logger "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env + runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () -runLlvmOpt logger dflags args = traceToolCommand logger dflags "opt" $ do +runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do let (p,args0) = pgm_lo dflags args1 = map Option (getOpts dflags opt_lo) -- We take care to pass -optlo flags (e.g. args0) last to ensure that the -- user can override flags passed by GHC. See #14821. - runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0) -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () -runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do +runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) - runSomething logger dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args) -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO () -runClang logger dflags args = traceToolCommand logger dflags "clang" $ do +runClang logger dflags args = traceToolCommand logger "clang" $ do let (clang,_) = pgm_lcc dflags -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. @@ -193,9 +193,9 @@ args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 catchException - (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env) + (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do - errorMsg logger dflags $ + errorMsg logger $ text ("Error running clang! you need clang installed to use the" ++ " LLVM backend") $+$ text "(or GHC tried to execute clang incorrectly)" @@ -204,7 +204,7 @@ -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do +figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) -- we grab the args even though they should be useless just in @@ -230,22 +230,23 @@ return mb_ver ) (\err -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - errorMsg logger dflags $ vcat + errorMsg logger $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ - text ("Make sure you have installed LLVM between " - ++ llvmVersionStr supportedLlvmVersionMin + text ("Make sure you have installed LLVM between [" + ++ llvmVersionStr supportedLlvmVersionLowerBound ++ " and " - ++ llvmVersionStr supportedLlvmVersionMax) ] + ++ llvmVersionStr supportedLlvmVersionUpperBound + ++ ")") ] return Nothing) runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runLink logger tmpfs dflags args = traceToolCommand logger dflags "linker" $ do +runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do -- See Note [Run-time linker info] -- -- `-optl` args come at the end, so that later `-l` options @@ -310,7 +311,7 @@ -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args = - traceToolCommand logger dflags "merge-objects" $ do + traceToolCommand logger "merge-objects" $ do let (p,args0) = pgm_lm dflags optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args @@ -321,40 +322,40 @@ mb_env <- getGccEnv args2 runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env else do - runSomething logger dflags "Merge objects" p args2 + runSomething logger "Merge objects" p args2 runLibtool :: Logger -> DynFlags -> [Option] -> IO () -runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do +runLibtool logger dflags args = traceToolCommand logger "libtool" $ do linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags let args1 = map Option (getOpts dflags opt_l) args2 = [Option "-static"] ++ args1 ++ args ++ linkargs libtool = pgm_libtool dflags mb_env <- getGccEnv args2 - runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env + runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do +runAr logger dflags cwd args = traceToolCommand logger "ar" $ do let ar = pgm_ar dflags - runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing + runSomethingFiltered logger id "Ar" ar args cwd Nothing askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String askOtool logger dflags mb_cwd args = do let otool = pgm_otool dflags - runSomethingWith logger dflags "otool" otool args $ \real_args -> + runSomethingWith logger "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () runInstallNameTool logger dflags args = do let tool = pgm_install_name_tool dflags - runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing + runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do +runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do let ranlib = pgm_ranlib dflags - runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing + runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do +runWindres logger dflags args = traceToolCommand logger "windres" $ do let cc = pgm_c dflags cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags @@ -374,11 +375,11 @@ : Option "--use-temp-file" : args mb_env <- getGccEnv cc_args - runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env + runSomethingFiltered logger id "Windres" windres args' Nothing mb_env touch :: Logger -> DynFlags -> String -> String -> IO () -touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $ - runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg] +touch logger dflags purpose arg = traceToolCommand logger "touch" $ + runSomething logger purpose (pgm_T dflags) [FileOption "" arg] -- * Tracing utility @@ -389,6 +390,5 @@ -- -- For those events to show up in the eventlog, you need -- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a -traceToolCommand logger dflags tool = withTiming logger - dflags (text $ "systool:" ++ tool) (const ()) +traceToolCommand :: Logger -> String -> IO a -> IO a +traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -18,6 +18,7 @@ import GHC.Hs import GHC.Driver.Session +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin @@ -46,6 +47,7 @@ import GHC.Utils.Error import GHC.Core.DataCon import GHC.Data.Maybe +import GHC.Types.Hint import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet @@ -235,7 +237,7 @@ ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances" + liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances" FormatHaskell (ddump_deriving inst_info rn_binds famInsts)) @@ -738,9 +740,10 @@ warnUselessTypeable :: TcM () warnUselessTypeable - = do { addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } + = do { addDiagnosticTc $ TcRnUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingTypeable) noHints $ + text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance @@ -1609,7 +1612,10 @@ -- DeriveAnyClass, but emitting a warning about the choice. -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $ - lift $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep + lift $ addDiagnosticTc + $ TcRnUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingDefaults) noHints + $ sep [ text "Both DeriveAnyClass and" <+> text "GeneralizedNewtypeDeriving are enabled" , text "Defaulting to the DeriveAnyClass strategy" @@ -1998,9 +2004,8 @@ ; case wildcard of Nothing -> pure () Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) - diagnosticTc (WarningWithFlag Opt_WarnPartialTypeSignatures) - wpartial_sigs partial_sig_msg + checkTc xpartial_sigs (partial_sig_msg [pts_suggestion]) + diagnosticTc wpartial_sigs (partial_sig_msg noHints) -- Check for Generic instances that are derived with an exotic -- deriving strategy like DAC @@ -2011,14 +2016,21 @@ where exotic_mechanism = not $ isDerivSpecStock mechanism - partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) + partial_sig_msg :: [GhcHint] -> TcRnMessage + partial_sig_msg hints = TcRnUnknownMessage + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialTypeSignatures) hints $ + text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + pts_suggestion :: GhcHint pts_suggestion - = text "To use the inferred type, enable PartialTypeSignatures" + = UnknownHint (text "To use the inferred type, enable PartialTypeSignatures") - gen_inst_err = text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." + gen_inst_err :: TcRnMessage + gen_inst_err = TcRnUnknownMessage + $ mkPlainError noHints $ + text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." derivingThingFailWith :: Bool -- If True, add a snippet about how not even -- GeneralizedNewtypeDeriving would make this @@ -2206,8 +2218,9 @@ ************************************************************************ -} -nonUnaryErr :: LHsSigType GhcRn -> SDoc -nonUnaryErr ct = quotes (ppr ct) +nonUnaryErr :: LHsSigType GhcRn -> TcRnMessage +nonUnaryErr ct = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr ct) <+> text "is not a unary constraint, as expected by a deriving clause" nonStdErr :: Class -> SDoc @@ -2222,9 +2235,10 @@ derivingNullaryErr :: SDoc derivingNullaryErr = text "Cannot derive instances for nullary classes" -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> TcRnMessage derivingKindErr tc cls cls_tys cls_kind enough_args - = sep [ hang (text "Cannot derive well-kinded instance of form" + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ hang (text "Cannot derive well-kinded instance of form" <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> text "..."))) 2 gen1_suggestion @@ -2237,35 +2251,37 @@ = text "(Perhaps you intended to use PolyKinds)" | otherwise = Outputable.empty -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> TcRnMessage derivingViaKindErr cls cls_kind via_ty via_kind - = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) + = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ + hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> SDoc +derivingEtaErr :: Class -> [Type] -> Type -> TcRnMessage derivingEtaErr cls cls_tys inst_ty - = sep [text "Cannot eta-reduce to an instance of form", + = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ + sep [text "Cannot eta-reduce to an instance of form", nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> TcRnMessage derivingThingErr newtype_deriving cls cls_args mb_strat why = derivingThingErr' newtype_deriving cls cls_args mb_strat (maybe empty derivStrategyName mb_strat) why -derivingThingErrM :: Bool -> SDoc -> DerivM SDoc +derivingThingErrM :: Bool -> SDoc -> DerivM TcRnMessage derivingThingErrM newtype_deriving why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why -derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc +derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM TcRnMessage derivingThingErrMechanism mechanism why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args @@ -2274,9 +2290,10 @@ (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> TcRnMessage derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = sep [(hang (text "Can't make a derived instance of") + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred) <+> via_mechanism) $$ nest 2 extra) <> colon, nest 2 why] diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -32,7 +32,7 @@ import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import GHC.Utils.Monad.State +import GHC.Utils.Monad.State.Strict import GHC.Tc.Deriv.Generate import GHC.Tc.Utils.TcType import GHC.Core.TyCon diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -909,7 +909,7 @@ | cls_key == eqClassKey = check_in arg_ty ordOpTbl | cls_key == ordClassKey = check_in arg_ty ordOpTbl | cls_key == showClassKey = check_in arg_ty boxConTbl - | cls_key == liftClassKey = True -- Lift is levity-polymorphic + | cls_key == liftClassKey = True -- Lift is representation-polymorphic | otherwise = False -- Read, Ix etc check_in :: Type -> [(Type,a)] -> Bool 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 @@ -14,66 +14,73 @@ import GHC.Prelude +import GHC.Driver.Env (hsc_units) +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Config.Diagnostic + import GHC.Tc.Types import GHC.Tc.Utils.Monad +import GHC.Tc.Errors.Types import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Unify( occCheckForErrors, CheckTyEqResult(..) ) import GHC.Tc.Utils.Env( tcInitTidyEnv ) import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify ( checkTyVarEq ) import GHC.Tc.Types.Origin -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys, flattenTys ) -import GHC.Unit.Module -import GHC.Tc.Instance.Family -import GHC.Tc.Utils.Instantiate -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Core.DataCon import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm -import GHC.Hs.Binds ( PatSynBind(..) ) +import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) + import GHC.Types.Name import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) -import GHC.Builtin.Names ( typeableClassName ) import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Data.Bag -import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) +import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error + +import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) +import GHC.Unit.Module +import GHC.Hs.Binds ( PatSynBind(..) ) +import GHC.Builtin.Names ( typeableClassName ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) +import GHC.Core.Unify ( tcMatchTys, flattenTys ) +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon import GHC.Core.ConLike ( ConLike(..)) + +import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) import GHC.Utils.Misc -import GHC.Data.FastString import GHC.Utils.Outputable as O import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Types.SrcLoc -import GHC.Driver.Session -import GHC.Driver.Ppr +import GHC.Utils.FV ( fvVarList, unionFV ) + +import GHC.Data.Bag +import GHC.Data.FastString import GHC.Data.List.SetOps ( equivClasses ) import GHC.Data.Maybe -import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.FV ( fvVarList, unionFV ) import qualified GHC.Data.Strict as Strict import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) - -import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) - -- import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -600,10 +607,10 @@ , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - -- also checks to make sure the constraint isn't BlockedCIS + -- also checks to make sure the constraint isn't HoleBlockerReason -- See TcCanonical Note [Equalities with incompatible kinds], (4) unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool - unblocked _ (CIrredCan { cc_status = BlockedCIS {}}) _ = False + unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False unblocked checker ct pred = checker ct pred -- rigid_nom_eq, rigid_nom_tv_eq, @@ -719,8 +726,8 @@ -> ReportErrCtxt -> [Hole] -> TcM () reportHoles tidy_cts ctxt holes = do - df <- getDynFlags - let severity = diagReasonSeverity df (cec_type_holes ctxt) + diag_opts <- initDiagOpts <$> getDynFlags + let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt) holes' = filter (keepThisHole severity) holes -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError` -- because otherwise types will be zonked and tidied many times over. @@ -953,10 +960,10 @@ -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" ; dflags <- getDynFlags ; let err_msg = pprLocMsgEnvelope msg - err_fs = mkFastString $ showSDoc dflags $ + err_str = showSDoc dflags $ err_msg $$ text "(deferred type error)" - ; return $ evDelayedError ty err_fs } + ; return $ evDelayedError ty err_str } tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True @@ -1033,11 +1040,12 @@ -> TcM (MsgEnvelope TcRnMessage) mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkTcRnMessage rea + ; unit_state <- hsc_units <$> getTopEnv ; + ; let err_info = ErrInfo context (vcat $ relevant_bindings ++ valid_subs) + ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) + ; mkTcRnMessage (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (vcat important) - context - (vcat $ relevant_bindings ++ valid_subs) + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } -- This version does not include the context @@ -1046,10 +1054,13 @@ -> Report -> TcM (MsgEnvelope TcRnMessage) mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) - = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (vcat important) - O.empty - (vcat $ relevant_bindings ++ valid_subs) + = do { unit_state <- hsc_units <$> getTopEnv ; + ; let err_info = ErrInfo O.empty (vcat $ relevant_bindings ++ valid_subs) + ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) + ; mkTcRnMessage + (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) + } type UserGiven = Implication @@ -1544,6 +1555,22 @@ mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct -> TcTyVar -> TcType -> Report mkTyVarEqErr' dflags ctxt report ct tv1 ty2 + -- impredicativity is a simple error to understand; try it first + | check_eq_result `cterHasProblem` cteImpredicative + = let msg = vcat [ (if isSkolemTyVar tv1 + then text "Cannot equate type variable" + else text "Cannot instantiate unification variable") + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] + in + -- Unlike the other reports, this discards the old 'report_important' + -- instead of augmenting it. This is because the details are not likely + -- to be helpful since this is just an unimplemented feature. + mconcat [ headline_msg + , important msg + , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty + , report ] + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) @@ -1555,11 +1582,10 @@ , report ] - | CTE_Occurs <- occ_check_expand + | cterHasOccursCheck check_eq_result -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it - -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical = let extra2 = mkEqInfoMsg ct ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ @@ -1576,16 +1602,6 @@ in mconcat [headline_msg, extra2, extra3, report] - | CTE_Bad <- occ_check_expand - = let msg = vcat [ text "Cannot instantiate unification variable" - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] - in - -- Unlike the other reports, this discards the old 'report_important' - -- instead of augmenting it. This is because the details are not likely - -- to be helpful since this is just an unimplemented feature. - mconcat [ headline_msg, important msg, report ] - -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably -- it started life as a TyVarTv, else it'd have been unified, given @@ -1647,16 +1663,25 @@ | otherwise = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 - -- This *can* happen (#6123, and test T2627b) + -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 ty1 = mkTyVarTy tv1 - occ_check_expand = occCheckForErrors dflags tv1 ty2 - insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 + check_eq_result = case ct of + CIrredCan { cc_reason = NonCanonicalReason result } -> result + CIrredCan { cc_reason = HoleBlockerReason {} } -> cteProblem cteHoleBlocker + _ -> checkTyVarEq dflags tv1 ty2 + -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type + -- variable is on the right, so we don't get useful info for the CIrredCan, + -- and have to compute the result of checkTyVarEq here. + + + insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs + what = text $ levelString $ ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel @@ -2073,8 +2098,6 @@ -- True when the visible bit of the types look the same, -- so we want to show the kinds in the displayed type - - {- Note [Insoluble occurs check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble @@ -2085,7 +2108,7 @@ And indeed even thinking about the Givens is silly; [W] a ~ [a] is just as insoluble as Int ~ Bool. -Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck) +Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs) then report it directly, not in the "cannot deduce X from Y" form. This is done in misMatchOrCND (via the insoluble_occurs_check arg) @@ -3117,7 +3140,9 @@ , quotes (ppr default_ty) ]) 2 ppr_wanteds - ; setCtLocM loc $ diagnosticTc (WarningWithFlag Opt_WarnTypeDefaults) warn_default warn_msg } + ; let diag = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnTypeDefaults) noHints warn_msg + ; setCtLocM loc $ diagnosticTc warn_default diag } {- Note [Runtime skolems] @@ -3141,8 +3166,8 @@ ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) tidy_ty = tidyType tidy_env ty - msg - = vcat [ text "Reduction stack overflow; size =" <+> ppr depth + msg = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Reduction stack overflow; size =" <+> ppr depth , hang (text "When simplifying the following type:") 2 (ppr tidy_ty) , note ] diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -15,6 +15,7 @@ import GHC.Driver.Session import GHC.Driver.Env +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) import GHC.Tc.Utils.Monad @@ -27,6 +28,7 @@ import GHC.Types.Name import GHC.Types.Annotations import GHC.Types.SrcLoc +import GHC.Types.Error import Control.Monad ( when ) @@ -43,9 +45,10 @@ --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) - = do { setSrcSpanA loc $ addDiagnosticTc WarningWithoutFlag $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") + = do { let msg = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") + ; setSrcSpanA loc $ addDiagnosticTc msg ; return [] } tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation @@ -61,8 +64,10 @@ when (safeLanguageOn dflags) $ failWithTc safeHsErr runAnnotation target expr where - safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + safeHsErr :: TcRnMessage + safeHsErr = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] annProvenanceToTarget :: Module -> AnnProvenance GhcRn -> AnnTarget Name 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 @@ -24,6 +24,7 @@ import GHC.Builtin.Types (multiplicityTy) import GHC.Tc.Gen.Head import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate @@ -39,6 +40,7 @@ import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType ) import GHC.Core.Type import GHC.Tc.Types.Evidence +import GHC.Types.Error import GHC.Types.Var.Set import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names @@ -269,7 +271,7 @@ * ($): For a long time GHC has had a special typing rule for ($), that allows it to type (runST $ foo), which requires impredicative instantiation of ($), without language flags. It's a bit ad-hoc, but it's been that - way for ages. Using quickLookIds is the only special treatment ($) needs + way for ages. Using quickLookKeys is the only special treatment ($) needs now, which is a lot better. * leftSection, rightSection: these are introduced by the expansion step in @@ -693,7 +695,7 @@ | otherwise = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty - ; failWith $ + ; failWith $ TcRnUnknownMessage $ mkPlainError noHints $ text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ text "to a visible type argument" <+> quotes (ppr hs_ty) } @@ -1175,7 +1177,8 @@ ; return (mkHsWrap df_wrap tc_expr) }}}}} | otherwise - = failWithTc (text "tagToEnum# must appear applied to one value argument") + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "tagToEnum# must appear applied to one value argument") where vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args) @@ -1188,9 +1191,10 @@ , text "e.g. (tagToEnum# x) :: Bool" ] doc2 = text "Result type must be an enumeration type" - mk_error :: TcType -> SDoc -> SDoc + mk_error :: TcType -> SDoc -> TcRnMessage mk_error ty what - = hang (text "Bad call to tagToEnum#" + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Bad call to tagToEnum#" <+> text "at type" <+> ppr ty) 2 what diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -18,9 +18,10 @@ , tcCheckPolyExpr ) import GHC.Hs +import GHC.Hs.Syn.Type +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Match import GHC.Tc.Gen.Head( tcCheckId ) -import GHC.Tc.Utils.Zonk( hsLPatType ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.Bind @@ -37,6 +38,7 @@ import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity ) +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -182,7 +184,7 @@ ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (text "Predicate type of `ifThenElse' depends on result type") + (TcRnUnknownMessage $ mkPlainError noHints $ text "Predicate type of `ifThenElse' depends on result type") ; (pred', fun') <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) (mkCheckExpType r_ty) $ \ _ _ -> @@ -336,8 +338,9 @@ -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ - = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"]) -- | Typechecking for case command alternatives. Used for both -- 'HsCmdCase' and 'HsCmdLamCase'. 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 @@ -33,6 +33,7 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin @@ -233,8 +234,9 @@ -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: SDoc -badBootDeclErr = text "Illegal declarations in an hs-boot file" +badBootDeclErr :: TcRnMessage +badBootDeclErr = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal declarations in an hs-boot file" ------------------------ tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing @@ -436,7 +438,7 @@ -> LHsBinds (GhcPass p) -> TcM a recursivePatSynErr loc binds - = failAt loc $ + = failAt loc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Recursive pattern synonym definition with following bindings:") 2 (vcat $ map pprLBind . bagToList $ binds) where @@ -909,7 +911,8 @@ where report_dup_tyvar_tv_err (n1,n2) | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Couldn't match" <+> quotes (ppr n1) <+> text "with" <+> quotes (ppr n2)) 2 (hang (text "both bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) @@ -919,7 +922,8 @@ report_mono_sig_tv_err n | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Can't quantify over" <+> quotes (ppr n)) 2 (hang (text "bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) | otherwise -- Can't happen; by now we know it's a partial sig @@ -1011,7 +1015,9 @@ warnMissingSignatures flag msg id = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addDiagnosticTcM (WarningWithFlag flag) (env1, mk_msg tidy_ty) } + ; let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag flag) noHints (mk_msg tidy_ty) + ; addDiagnosticTcM (env1, dia) } where mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] @@ -1027,7 +1033,7 @@ , monomorphism_restriction_applies , let orig_sig = sig_inst_sig sig = setSrcSpan (sig_loc orig_sig) $ - failWith $ + failWith $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Overloaded signature conflicts with monomorphism restriction") 2 (ppr orig_sig) | otherwise diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -14,6 +14,7 @@ import GHC.Core.Class import GHC.Core.Type ( typeKind ) import GHC.Types.Var( tyVarKind ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType @@ -22,6 +23,7 @@ import GHC.Tc.Validity import GHC.Tc.Utils.TcType import GHC.Builtin.Names +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -101,9 +103,10 @@ defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc +dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) - = hang (text "Multiple default declarations") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where pp :: LDefaultDecl GhcRn -> SDoc @@ -111,7 +114,8 @@ = text "here was another default declaration" <+> ppr (locA locn) dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" -badDefaultTy :: Type -> [Class] -> SDoc +badDefaultTy :: Type -> [Class] -> TcRnMessage badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -237,8 +237,7 @@ -- so that's how we handle it, except we also export the data family -- when a data instance is exported. = do { - ; warnIfFlag Opt_WarnMissingExportList - True + ; addDiagnostic (missingModuleExportWarn $ moduleName _this_mod) ; let avails = map fix_faminst . gresToAvailInfo @@ -284,8 +283,7 @@ exports_from_item (ExportAccum occs earlier_mods) (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { warnIfFlag Opt_WarnDuplicateExports True - (dupModuleExport mod) ; + = do { addDiagnostic (dupModuleExport mod) ; return Nothing } | otherwise @@ -300,9 +298,7 @@ } ; checkErr exportValid (moduleNotImported mod) - ; warnIfFlag Opt_WarnDodgyExports - (exportValid && null gre_prs) - (nullModuleExport mod) + ; warnIf (exportValid && null gre_prs) (nullModuleExport mod) ; traceRn "efa" (ppr mod $$ ppr all_gres) ; addUsedGREs all_gres @@ -611,8 +607,9 @@ psErr = exportErrCtxt "pattern synonym" selErr = exportErrCtxt "pattern synonym record selector" - assocClassErr :: SDoc - assocClassErr = text "Pattern synonyms can be bundled only with datatypes." + assocClassErr :: TcRnMessage + assocClassErr = TcRnUnknownMessage $ mkPlainError noHints $ + text "Pattern synonyms can be bundled only with datatypes." handle_pat_syn :: SDoc -> TyCon -- ^ Parent TyCon @@ -641,8 +638,8 @@ expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) (_, _, _, _, _, res_ty) = patSynSig pat_syn mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = + typeMismatchError :: TcRnMessage + typeMismatchError = TcRnUnknownMessage $ mkPlainError noHints $ text "Pattern synonyms can only be bundled with matching type constructors" $$ text "Couldn't match expected type of" <+> quotes (ppr expected_res_ty) @@ -670,9 +667,7 @@ | greNameMangledName child == greNameMangledName child' -- Duplicate export -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. - -> do { warnIfFlag Opt_WarnDuplicateExports - (not (dupExport_ok child ie ie')) - (dupExportWarn child ie ie') + -> do { warnIf (not (dupExport_ok child ie ie')) (dupExportWarn child ie ie') ; return occs } | otherwise -- Same occ name but different names: an error @@ -734,27 +729,31 @@ single _ = False -dupModuleExport :: ModuleName -> SDoc +dupModuleExport :: ModuleName -> TcRnMessage dupModuleExport mod - = hsep [text "Duplicate", + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $ + hsep [text "Duplicate", quotes (text "Module" <+> ppr mod), text "in export list"] -moduleNotImported :: ModuleName -> SDoc +moduleNotImported :: ModuleName -> TcRnMessage moduleNotImported mod - = hsep [text "The export item", + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "The export item", quotes (text "module" <+> ppr mod), text "is not imported"] -nullModuleExport :: ModuleName -> SDoc +nullModuleExport :: ModuleName -> TcRnMessage nullModuleExport mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "exports nothing"] + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyExports) noHints $ + hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "exports nothing"] -missingModuleExportWarn :: ModuleName -> SDoc +missingModuleExportWarn :: ModuleName -> TcRnMessage missingModuleExportWarn mod - = hsep [text "The export item", + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingExportList) noHints $ + hsep [text "The export item", quotes (text "module" <+> ppr mod), text "is missing an export list"] @@ -770,20 +769,22 @@ where exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE GhcPs -> SDoc +exportItemErr :: IE GhcPs -> TcRnMessage exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ text "The export item" <+> quotes (ppr export_item), text "attempts to export constructors or class methods that are not visible here" ] -dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc +dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage dupExportWarn child ie1 ie2 - = hsep [quotes (ppr child), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $ + hsep [quotes (ppr child), + text "is exported by", quotes (ppr ie1), + text "and", quotes (ppr ie2)] -dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc -dcErrMsg ty_con what_is thing parents = +dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> TcRnMessage +dcErrMsg ty_con what_is thing parents = TcRnUnknownMessage $ mkPlainError noHints $ text "The type constructor" <+> quotes (ppr ty_con) <+> text "is not the parent of the" <+> text what_is <+> quotes thing <> char '.' @@ -809,9 +810,10 @@ exportClashErr :: GlobalRdrEnv -> GreName -> GreName -> IE GhcPs -> IE GhcPs - -> SDoc + -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon , ppr_export child1' gre1' ie1' , ppr_export child2' gre2' ie2' ] diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -30,13 +30,16 @@ import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import GHC.Hs +import GHC.Hs.Syn.Type import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic +import GHC.Types.Error import GHC.Core.Multiplicity import GHC.Core.UsageEnv +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head @@ -1288,7 +1291,8 @@ -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head reportAmbiguousField :: TyCon -> TcM () reportAmbiguousField parent_type = - setSrcSpan loc $ warnIfFlag Opt_WarnAmbiguousFields True $ + setSrcSpan loc $ addDiagnostic $ + TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnAmbiguousFields) noHints $ vcat [ text "The record update" <+> ppr rupd <+> text "with type" <+> ppr parent_type <+> text "is ambiguous." @@ -1404,9 +1408,12 @@ -- Illegal if any arg is strict addErrTc (missingStrictFields con_like []) else do - when (notNull field_strs && null field_labels) - (diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True - (missingFields con_like [])) + when (notNull field_strs && null field_labels) $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) + noHints + (missingFields con_like []) + (diagnosticTc True msg) | otherwise = do -- A record unless (null missing_s_fields) $ do @@ -1421,8 +1428,11 @@ -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. - diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True - (missingFields con_like fs) + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) + noHints + (missingFields con_like fs) + diagnosticTc True msg where -- we zonk the fields to get better types in error messages (#18869) @@ -1463,9 +1473,10 @@ fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" -badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc +badFieldTypes :: [(FieldLabelString,TcType)] -> TcRnMessage badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Record update for insufficiently polymorphic field" <> plural prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) @@ -1473,9 +1484,10 @@ :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to - -> SDoc + -> TcRnMessage badFieldsUpd rbinds data_cons - = hang (text "No constructor has all these fields:") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "No constructor has all these fields:") 2 (pprQuotedList conflictingFields) -- See Note [Finding the conflicting fields] where @@ -1545,9 +1557,10 @@ a decent stab, no more. See #7989. -} -mixedSelectors :: [Id] -> [Id] -> SDoc +mixedSelectors :: [Id] -> [Id] -> TcRnMessage mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = text "Cannot use a mixture of pattern synonym and record selectors" $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot use a mixture of pattern synonym and record selectors" $$ text "Record selectors defined by" <+> quotes (ppr (tyConName rep_dc)) <> colon @@ -1562,9 +1575,9 @@ mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" -missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc +missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage missingStrictFields con fields - = vcat [header, nest 2 rest] + = TcRnUnknownMessage $ mkPlainError noHints $ vcat [header, nest 2 rest] where pprField (f,ty) = ppr f <+> dcolon <+> ppr ty rest | null fields = Outputable.empty -- Happens for non-record constructors @@ -1588,15 +1601,17 @@ -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) -noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc +noPossibleParents :: [LHsRecUpdField GhcRn] -> TcRnMessage noPossibleParents rbinds - = hang (text "No type has all these fields:") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "No type has all these fields:") 2 (pprQuotedList fields) where fields = map (hfbLHS . unLoc) rbinds -badOverloadedUpdate :: SDoc -badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" +badOverloadedUpdate :: TcRnMessage +badOverloadedUpdate = TcRnUnknownMessage $ mkPlainError noHints $ + text "Record update is ambiguous, and requires a type signature" {- ************************************************************************ @@ -1675,8 +1690,8 @@ -- -- when the final node has a non-closed type. -- - explain :: Name -> NotClosedReason -> SDoc - explain name reason = + explain :: Name -> NotClosedReason -> TcRnMessage + explain name reason = TcRnUnknownMessage $ mkPlainError noHints $ quotes (ppr name) <+> text "is used in a static form but it is not closed" <+> text "because it" $$ diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -39,6 +39,7 @@ import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr @@ -306,11 +307,13 @@ | cconv == PrimCallConv = do dflags <- getDynFlags checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + (TcRnUnknownMessage $ mkPlainError noHints $ + text "Use GHCForeignImportPrim to allow `foreign import prim'.") checkCg checkCOrAsmOrLlvmOrInterp checkCTarget target checkTc (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + (TcRnUnknownMessage $ mkPlainError noHints $ + text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty @@ -326,7 +329,8 @@ case target of StaticTarget _ _ _ False | not (null arg_tys) -> - addErrTc (text "`value' imports cannot have function types") + addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + text "`value' imports cannot have function types") _ -> return () return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src @@ -344,8 +348,9 @@ checkMissingAmpersand :: [Type] -> Type -> TcM () checkMissingAmpersand arg_tys res_ty | null arg_tys && isFunPtrTy res_ty - = addDiagnosticTc (WarningWithFlag Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") + = addDiagnosticTc $ TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyForeignImports) noHints + (text "possible missing & in foreign import of FunPtr") | otherwise = return () @@ -519,7 +524,8 @@ _ -> case check bcknd of IsValid -> return () - NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) + NotValid err -> + addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal foreign declaration:" <+> err) -- Calling conventions @@ -531,26 +537,33 @@ if platformArch platform == ArchX86 then return StdCallConv else do -- This is a warning, not an error. see #3336 - addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnUnsupportedCallingConventions) + noHints + (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + addDiagnosticTc msg return CCallConv -checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") - return PrimCallConv +checkCConv PrimCallConv = do + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints + (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv checkCConv JavaScriptCallConv = do dflags <- getDynFlags if platformArch (targetPlatform dflags) == ArchJavaScript then return JavaScriptCallConv - else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv + else do + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "The `javascript' calling convention is unsupported on this platform") + return JavaScriptCallConv -- Warnings -check :: Validity -> (SDoc -> SDoc) -> TcM () +check :: Validity -> (SDoc -> TcRnMessage) -> TcM () check IsValid _ = return () check (NotValid doc) err_fn = addErrTc (err_fn doc) -illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr :: SDoc -> SDoc -> TcRnMessage illegalForeignTyErr arg_or_res extra - = hang msg 2 extra + = TcRnUnknownMessage $ mkPlainError noHints $ hang msg 2 extra where msg = hsep [ text "Unacceptable", arg_or_res , text "type in foreign declaration:"] @@ -560,9 +573,10 @@ argument = text "argument" result = text "result" -badCName :: CLabelString -> SDoc +badCName :: CLabelString -> TcRnMessage badCName target - = sep [quotes (ppr target) <+> text "is not a valid C identifier"] + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [quotes (ppr target) <+> text "is not a valid C identifier"] foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc foreignDeclCtxt fo 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 @@ -39,19 +39,22 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic +import GHC.Types.Error import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core.UsageEnv ( unitUE ) import GHC.Rename.Utils ( unknownSubordinateErr ) +import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) +import GHC.Unit.Module ( getModule ) import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Zonk ( hsLitType ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Hs +import GHC.Hs.Syn.Type import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.PatSyn( PatSyn ) @@ -459,7 +462,7 @@ -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here - _ -> failWithTc $ + _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ ppr thing <+> text "used where a value identifier was expected" } ------------------------ @@ -509,17 +512,20 @@ Nothing -> failWithTc (notSelector (greMangledName gre)) } -fieldNotInType :: RecSelParent -> RdrName -> SDoc +fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + = TcRnUnknownMessage $ mkPlainError noHints $ + unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr -notSelector :: Name -> SDoc +notSelector :: Name -> TcRnMessage notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [quotes (ppr field), text "is not a record selector"] -naughtyRecordSel :: OccName -> SDoc +naughtyRecordSel :: OccName -> TcRnMessage naughtyRecordSel lbl - = text "Cannot use record selector" <+> quotes (ppr lbl) <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot use record selector" <+> quotes (ppr lbl) <+> text "as a function due to escaped type variables" $$ text "Probable fix: use pattern-matching syntax instead" @@ -702,47 +708,53 @@ tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) tc_infer_id id_name = do { thing <- tcLookup id_name - ; global_env <- getGlobalRdrEnv ; case thing of ATcId { tct_id = id } -> do { check_local_id id ; return_id id } - AGlobal (AnId id) - -> return_id id + AGlobal (AnId id) -> return_id id -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment -- Hence no checkTh stuff here - AGlobal (AConLike cl) -> case cl of - RealDataCon con -> tcInferDataCon con - PatSynCon ps -> tcInferPatSyn id_name ps - - AGlobal (ATyCon ty_con) - -> fail_tycon global_env ty_con - - ATyVar name _ - -> failWithTc $ - text "Illegal term-level use of the type variable" - <+> quotes (ppr name) - $$ nest 2 (text "bound at" <+> ppr (getSrcLoc name)) - - ATcTyCon ty_con - -> fail_tycon global_env ty_con + AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con + AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps + AGlobal (ATyCon tc) -> fail_tycon tc + ATcTyCon tc -> fail_tycon tc + ATyVar name _ -> fail_tyvar name - _ -> failWithTc $ + _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ ppr thing <+> text "used where a value identifier was expected" } where - fail_tycon global_env ty_con = - let pprov = case lookupGRE_Name global_env (tyConName ty_con) of + fail_tycon tc = do + gre <- getGlobalRdrEnv + let msg = text "Illegal term-level use of the type constructor" + <+> quotes (ppr (tyConName tc)) + pprov = case lookupGRE_Name gre (tyConName tc) of Just gre -> nest 2 (pprNameProvenance gre) Nothing -> empty - in failWithTc (term_level_tycons ty_con $$ pprov) + suggestions <- get_suggestions dataName + failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions)) - term_level_tycons ty_con - = text "Illegal term-level use of the type constructor" - <+> quotes (ppr (tyConName ty_con)) + fail_tyvar name = do + let msg = text "Illegal term-level use of the type variable" + <+> quotes (ppr name) + pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc name)) + suggestions <- get_suggestions varName + failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions)) + get_suggestions ns = do + let occ = mkOccNameFS ns (occNameFS (occName id_name)) + dflags <- getDynFlags + rdr_env <- getGlobalRdrEnv + lcl_env <- getLocalRdrEnv + imp_info <- getImports + curr_mod <- getModule + hpt <- getHpt + return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env + lcl_env imp_info (mkRdrUnqual occ) + return_id id = return (HsVar noExtField (noLocA id), idType id) check_local_id :: Id -> TcM () @@ -788,9 +800,10 @@ Just (expr,ty) -> return (expr,ty) Nothing -> failWithTc (nonBidirectionalErr id_name) -nonBidirectionalErr :: Outputable name => name -> SDoc -nonBidirectionalErr name = text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" +nonBidirectionalErr :: Outputable name => name -> TcRnMessage +nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" {- Note [Typechecking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -809,7 +822,7 @@ 2. We are going to return a ConLikeTc, thus: XExpr (ConLikeTc K [r,a] [Scaled p a]) - :: forall (r :: RuntimeRep) (a :: Type r). a %p -> T r a + :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a where 'p' is a fresh multiplicity unification variable. To get the returned ConLikeTc, we allocate a fresh multiplicity @@ -970,9 +983,10 @@ checkCrossStageLifting _ _ _ = return () -polySpliceErr :: Id -> SDoc +polySpliceErr :: Id -> TcRnMessage polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Can't splice the polymorphic local variable" <+> quotes (ppr id) {- Note [Lifting strings] 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 @@ -78,6 +78,7 @@ import GHC.Hs import GHC.Rename.Utils +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Core.Predicate @@ -96,6 +97,7 @@ tcInstInvisibleTyBinder ) import GHC.Core.Type import GHC.Builtin.Types.Prim +import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.Name.Reader( lookupLocalRdrOcc ) import GHC.Types.Var @@ -624,7 +626,8 @@ (kind_args, _) = splitFunTys (tcTypeKind pred) ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) - Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } -- | Typecheck a deriving strategy. For most deriving strategies, this is a -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. @@ -1130,7 +1133,7 @@ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210, #14761) - = do { let bangError err = failWith $ + = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ text err <+> text "annotation cannot appear nested inside a type" ; case bang of @@ -1141,7 +1144,8 @@ tc_hs_type _ ty@(HsRecTy {}) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now - = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Record syntax is illegal here:" <+> ppr ty) -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment @@ -1155,7 +1159,8 @@ -- This should never happen; type splices are expanded by the renamer tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (text "Unexpected type splice:" <+> ppr ty) + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind @@ -1163,7 +1168,7 @@ tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind | op `hasKey` funTyConKey - = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind + = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind @@ -1703,8 +1708,9 @@ n_initial_val_args _ = 0 ty_app_err arg ty - = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) + = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) mkAppTyM :: TCvSubst @@ -2722,8 +2728,8 @@ | otherwise = (reverse acc, bs, substTy subst ki) -tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc -tooManyBindersErr ki bndrs = +tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage +tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Not a function kind:") 4 (ppr ki) $$ hang (text "but extra binders found:") @@ -3770,8 +3776,8 @@ AnyBoxedKind -> ppr boxedRepDataConTyCon LiftedKind -> ppr liftedTypeKind - err_msg :: DynFlags -> SDoc - err_msg dflags = + err_msg :: DynFlags -> TcRnMessage + err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $ sep [ sep [ pp_dec <+> text "has non-" <> pp_allowed_kind dflags @@ -3796,8 +3802,8 @@ checkClassKindSig :: Kind -> TcM () checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg where - err_msg :: SDoc - err_msg = + err_msg :: TcRnMessage + err_msg = TcRnUnknownMessage $ mkPlainError noHints $ text "Kind signature on a class must end with" <+> ppr constraintKind $$ text "unobscured by type families" @@ -4248,7 +4254,8 @@ promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") 2 (parens reason)) where reason = case err of 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 @@ -41,6 +41,7 @@ , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat @@ -68,6 +69,7 @@ import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) +import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id @@ -1124,7 +1126,8 @@ | null bad_matches = return () | otherwise - = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (vcat [ text "Equations for" <+> quotes (ppr fun) <+> text "have different numbers of arguments" , nest 2 (ppr (getLocA match1)) , nest 2 (ppr (getLocA (head bad_matches)))]) 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 @@ -30,11 +30,14 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) import GHC.Hs +import GHC.Hs.Syn.Type import GHC.Rename.Utils +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name @@ -447,8 +450,9 @@ -- (pat_ty -> inf_res_sigma) expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} + ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } + {- Note [View patterns and polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this exotic example: @@ -484,25 +488,16 @@ ------------------------ -- Lists, tuples, arrays - ListPat Nothing pats -> do + + -- Necessarily a built-in list pattern, not an overloaded list pattern. + -- See Note [Desugaring overloaded list patterns]. + ListPat _ pats -> do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty) ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) penv pats thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi - (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) -} - - ListPat (Just e) pats -> do - { tau_pat_ty <- expTypeToType (scaledThing pat_ty) - ; ((pats', res, elt_ty), e') - <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] - SynList $ - \ [elt_ty] _ -> - do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) - penv pats thing_inside - ; return (pats', res, elt_ty) } - ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) + (ListPat elt_ty pats') pat_ty, res) } TuplePat _ pats boxity -> do @@ -694,6 +689,9 @@ ; tc_pat pat_ty penv pat thing_inside } _ -> panic "invalid splice in splice pat" + XPat (HsPatExpanded lpat rpat) -> do + { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside + ; return (XPat $ ExpansionPat lpat rpat', res) } {- Note [Hopping the LIE in lazy patterns] @@ -772,9 +770,10 @@ 2 (ppr res_ty)) ] ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> SDoc +patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "You cannot bind scoped type variable" <> plural sig_tvs <+> pprQuotedList (map fst sig_tvs)) 2 (text "in a pattern binding signature") @@ -945,7 +944,8 @@ ; gadts_on <- xoptM LangExt.GADTs ; families_on <- xoptM LangExt.TypeFamilies ; checkTc (no_equalities || gadts_on || families_on) - (text "A pattern match on a GADT requires the" <+> + (TcRnUnknownMessage $ mkPlainError noHints $ + text "A pattern match on a GADT requires the" <+> text "GADTs or TypeFamilies language extension") -- #2905 decided that a *pattern-match* of a GADT -- should require the GADT language flag. @@ -1288,7 +1288,8 @@ -- by the calls to unifyType in tcConArgs, which will also unify -- kinds. ; when (not (null sig_ibs) && inPatBind penv) $ - addErr (text "Binding type variables is not allowed in pattern bindings") + addErr (TcRnUnknownMessage $ mkPlainError noHints $ + text "Binding type variables is not allowed in pattern bindings") ; result <- tcExtendNameTyVarEnv sig_wcs $ tcExtendNameTyVarEnv sig_ibs $ thing_inside @@ -1318,9 +1319,10 @@ conTyArgArityErr :: ConLike -> Int -- expected # of arguments -> Int -- actual # of arguments - -> SDoc + -> TcRnMessage conTyArgArityErr con_like expected_number actual_number - = text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number {- @@ -1452,18 +1454,21 @@ checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat checkExistentials _ _ _ = return () -existentialLazyPat :: SDoc +existentialLazyPat :: TcRnMessage existentialLazyPat - = hang (text "An existential or GADT data constructor cannot be used") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "An existential or GADT data constructor cannot be used") 2 (text "inside a lazy (~) pattern") -existentialProcPat :: SDoc +existentialProcPat :: TcRnMessage existentialProcPat - = text "Proc patterns cannot use existential or GADT data constructors" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Proc patterns cannot use existential or GADT data constructors" -badFieldCon :: ConLike -> FieldLabelString -> SDoc +badFieldCon :: ConLike -> FieldLabelString -> TcRnMessage badFieldCon con field - = hsep [text "Constructor" <+> quotes (ppr con), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Constructor" <+> quotes (ppr con), text "does not have field", quotes (ppr field)] polyPatSig :: TcType -> SDoc diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -26,7 +26,13 @@ import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Backend + import GHC.Hs + + +import GHC.Tc.Errors.Types ( TcRnMessage(..), LevityCheckProvenance(..) ) import GHC.Tc.Gen.HsType import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) @@ -40,26 +46,30 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) + import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Ppr +import GHC.Types.Error import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, setInlinePragma , mkLocalId, realIdUnfolding ) -import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic -import GHC.Unit.Module( getModule ) import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Types.SrcLoc + +import GHC.Builtin.Names( mkUnboundName ) +import GHC.Unit.Module( getModule ) + import GHC.Utils.Misc as Utils ( singleton ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Trace + import GHC.Data.Maybe( orElse ) + import Data.Maybe( mapMaybe ) import Control.Monad( unless ) @@ -443,9 +453,9 @@ build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty -- arguments become the types of binders. We thus cannot allow - -- levity polymorphism here + -- representation polymorphism here ; let (arg_tys, _) = tcSplitFunTys body_ty - ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys + ; mapM_ (checkForLevPoly LevityCheckPatSynSig . scaledThing) arg_tys ; traceTc "tcTySig }" $ vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs) @@ -613,10 +623,12 @@ warn_multiple_inlines inl2 inls | otherwise = setSrcSpanA loc $ - addDiagnosticTc WarningWithoutFlag - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints $ + (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (inl1:inl2:inls)))) + in addDiagnosticTc dia pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -746,9 +758,11 @@ is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) warn_discarded_sigs - = addDiagnosticTc WarningWithoutFlag - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) + = let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints $ + (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) bad_sigs))) + in addDiagnosticTc dia -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] @@ -761,10 +775,11 @@ -- However we want to use fun_name in the error message, since that is -- what the user wrote (#8537) = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) - -- Note [SPECIALISE pragmas] + do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ + TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints + (text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name)) + -- Note [SPECIALISE pragmas] ; spec_prags <- mapM tc_one hs_tys ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) ; return spec_prags } @@ -829,7 +844,9 @@ ; if hasSomeUnfolding (realIdUnfolding id) -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag - else do { addDiagnosticTc WarningWithoutFlag (impSpecErr name) + else do { let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name) + ; addDiagnosticTc dia ; return [] } } impSpecErr :: Name -> SDoc diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -38,6 +38,7 @@ import GHC.Driver.Session import GHC.Driver.Env import GHC.Driver.Hooks +import GHC.Driver.Config.Diagnostic import GHC.Hs @@ -210,12 +211,13 @@ ; let rep = getRuntimeRep expr_ty ; meta_ty <- tcTExpTy m_var expr_ty ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeCodeCoerceName + ; codeco <- tcLookupId unsafeCodeCoerceName + ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) - (nlHsTyApp texpco [rep, expr_ty])) - (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps')))) + (nlHsTyApp codeco [rep, expr_ty])) + (noLocA (HsTcBracketOut bracket_ty (Just wrapper) brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack) @@ -244,7 +246,7 @@ -- Unify the overall type of the bracket with the expected result -- type ; tcWrapResultO BracketOrigin rn_expr - (HsTcBracketOut noExtField brack_info brack ps') + (HsTcBracketOut expected_type brack_info brack ps') expected_type res_ty } @@ -322,7 +324,8 @@ ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } where err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal polytype:" <+> ppr ty , text "The type of a Typed Template Haskell expression must" <+> text "not have any quantification." ] @@ -690,7 +693,7 @@ ; mod_finalizers <- readTcRef modfinalizers_ref ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers -- We use orig_expr here and not q_expr when tracing as a call to - -- unsafeTExpCoerce is added to the original expression by the + -- unsafeCodeCoerce is added to the original expression by the -- typechecker when typed quotes are type checked. ; traceSplice (SpliceInfo { spliceDescription = "expression" , spliceIsDecl = False @@ -993,8 +996,8 @@ -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all -- cases. ; logger <- getLogger - ; dflags <- getDynFlags - ; liftIO $ printMessages logger dflags ds_msgs + ; diag_opts <- initDiagOpts <$> getDynFlags + ; liftIO $ printMessages logger diag_opts ds_msgs ; ds_expr <- case mb_ds_expr of Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice] @@ -1006,9 +1009,10 @@ -- Compile and link it; might fail if linking fails ; src_span <- getSrcSpanM + ; mnwib <- getMnwib ; traceTc "About to run (desugared)" (ppr ds_expr) ; either_hval <- tryM $ liftIO $ - GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr + GHC.Driver.Main.hscCompileCoreExpr hsc_env (src_span, Just mnwib) ds_expr ; case either_hval of { Left exn -> fail_with_exn "compile and link" exn ; Right hval -> do @@ -1030,7 +1034,7 @@ -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc err + Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1048,7 +1052,7 @@ let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", nest 2 (text exn_msg), if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg + failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) {- Note [Running typed splices in the zonker] @@ -1164,8 +1168,9 @@ -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addDiagnostic WarningWithoutFlag (text msg) + qReport True msg = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg) + qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -1213,7 +1218,7 @@ th_origin <- getThSpliceOrigin let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of - Left exn -> failWithTc $ + Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Error in a declaration passed to addTopDecls:") 2 exn Right ds -> return ds @@ -1231,7 +1236,8 @@ checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" + = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" bindName :: RdrName -> TcM () bindName (Exact n) @@ -1240,7 +1246,7 @@ } bindName name = - addErr $ + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") @@ -1266,8 +1272,8 @@ 2 (text "Plugins in the current package can't be specified.") case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err + Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err + FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err _ -> return () th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv updTcRef th_coreplugins_var (plugin:) @@ -1292,7 +1298,7 @@ th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ text + unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Can't add documentation to" <+> ppr_loc doc_loc <+> text "as it isn't inside the current module" updTcRef th_doc_var (Map.insert resolved_doc_loc s) @@ -1378,7 +1384,7 @@ Right (_, (inst:_)) -> return $ getName inst Right (_, []) -> noMatches where - noMatches = failWithTc $ + noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't find any instances of" <+> ppr_th th_type <+> text "to add documentation to" @@ -1415,7 +1421,7 @@ inst_cls_name TH.WildCardT = inst_cls_name_err inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err - inst_cls_name_err = failWithTc $ + inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't work out what instance" <+> ppr_th th_type <+> text "is supposed to be" @@ -1705,15 +1711,16 @@ ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } + _ -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } where doc = ClassInstanceCtx bale_out msg = failWithTc msg cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc msg + Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) Right ty -> return ty {- @@ -1806,17 +1813,18 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg + Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) }}}} -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" +notInScope :: TH.Name -> TcRnMessage +notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" -- Ugh! Rather an indirect way to display the name -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" +notInEnv :: Name -> TcRnMessage +notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr name) <+> text "is not in the type environment at a reify" ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -1824,7 +1832,7 @@ = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) + _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) } where reify_role Nominal = TH.NominalR @@ -2611,15 +2619,17 @@ usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m + usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys noTH :: SDoc -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> s <+> - text "in Template Haskell:", - nest 2 d]) +noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (hsep [text "Can't represent" <+> s <+> + text "in Template Haskell:", + nest 2 d]) ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) 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 @@ -29,6 +29,7 @@ import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) @@ -41,6 +42,7 @@ import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo +import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name @@ -56,6 +58,7 @@ import GHC.Data.Maybe import Control.Monad +import Data.Bifunctor ( second ) import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Function ( on ) @@ -949,7 +952,7 @@ reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () reportConflictingInjectivityErrs _ [] _ = return () reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn - = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] + = addErrs [second mk_err $ buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] where herald = text "Type family equation right-hand sides overlap; this violates" $$ text "the family's injectivity annotation:" @@ -974,7 +977,7 @@ herald $$ text "In the type family equation:") (tyfamEqn :| []) - in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) + in addErrAt loc (mk_err $ pprWithExplicitKindsWhen has_kinds doc) where herald = sep [ what <+> text "variable" <> pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) @@ -991,7 +994,7 @@ -- level of RHS reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () reportTfHeadedErr fam_tc branch - = addErrs [buildInjectivityError fam_tc + = addErrs [second mk_err $ buildInjectivityError fam_tc (injectivityErrorHerald $$ text "RHS of injective type family equation cannot" <+> text "be a type family:") @@ -1001,7 +1004,7 @@ -- but LHS pattern is not a bare type variable. reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () reportBareVariableInRHSErr fam_tc tys branch - = addErrs [buildInjectivityError fam_tc + = addErrs [second mk_err $ buildInjectivityError fam_tc (injectivityErrorHerald $$ text "RHS of injective type family equation is a bare" <+> text "type variable" $$ @@ -1009,6 +1012,9 @@ text "variables:" <+> pprQuotedList tys) (branch :| [])] +mk_err :: SDoc -> TcRnMessage +mk_err = TcRnUnknownMessage . mkPlainError noHints + buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) = ( coAxBranchSpan eqn1 @@ -1023,7 +1029,7 @@ , let sorted = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst] fi1 = head sorted span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ + = setSrcSpan span $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Conflicting family instance declarations:") 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) | fi <- sorted diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -45,7 +45,7 @@ import GHC.Utils.Panic import GHC.Data.FastString ( FastString, mkFastString, fsLit ) -import Control.Monad.Trans.State +import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class (lift) import Data.Maybe ( isJust ) import Data.Word( Word64 ) 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 @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -52,6 +53,7 @@ import GHC.Driver.Env import GHC.Driver.Plugins import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) import GHC.Tc.Errors.Types @@ -197,7 +199,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc _ <- loc - = withTiming logger dflags + = withTiming logger (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ @@ -210,12 +212,10 @@ where hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env err_msg = mkPlainErrorMsgEnvelope loc $ - TcRnUnknownMessage $ mkPlainError noHints $ - text "Module does not have a RealSrcSpan:" <+> ppr this_mod + TcRnModMissingRealSrcSpan this_mod pair :: (Module, SrcSpan) pair@(this_mod,_) @@ -260,8 +260,10 @@ ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } - ; when (notNull prel_imports) $ - addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn) + ; when (notNull prel_imports) $ do + let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) + addDiagnostic msg ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = @@ -278,8 +280,11 @@ $ (simpleImportDecl mod_name) { ideclHiding = Just (False, noLocA [])} ; mkImport _ = panic "mkImport" } - ; let { all_imports = prel_imports ++ import_decls - ++ map mkImport (raw_sig_imports ++ raw_req_imports) } + ; let { withReason t imps = map (,text t) imps } + ; let { all_imports = withReason "is implicitly imported" prel_imports + ++ withReason "is directly imported" import_decls + ++ withReason "is an extra sig import" (map mkImport raw_sig_imports) + ++ withReason "is an implicit req import" (map mkImport raw_req_imports) } ; -- OK now finally rename the imports tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env all_imports @@ -360,7 +365,7 @@ ************************************************************************ -} -tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv +tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv tcRnImports hsc_env import_decls = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; @@ -607,7 +612,7 @@ { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpanA loc - $ addErr (text + $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text ("Declaration splices are not " ++ "permitted inside top-level " ++ "declarations added with addTopDecls")) @@ -729,7 +734,8 @@ badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) (char 'A' <+> text what + = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of HsBootFile -> text "hs-boot" @@ -1355,24 +1361,27 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- -missingBootThing :: Bool -> Name -> String -> SDoc +missingBootThing :: Bool -> Name -> String -> TcRnMessage missingBootThing is_boot name what - = quotes (ppr name) <+> text "is exported by the" + = TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr name) <+> text "is exported by the" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file, but not" <+> text what <+> text "the module" -badReexportedBootThing :: Bool -> Name -> Name -> SDoc +badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage badReexportedBootThing is_boot name name' - = withUserStyle alwaysQualify AllTheWay $ vcat + = TcRnUnknownMessage $ mkPlainError noHints $ + withUserStyle alwaysQualify AllTheWay $ vcat [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file (re)exports" <+> quotes (ppr name) , text "but the implementing module exports a different identifier" <+> quotes (ppr name') ] -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc +bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage bootMisMatch is_boot extra_info real_thing boot_thing - = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc + = TcRnUnknownMessage $ mkPlainError noHints $ + pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc where to_doc = pprTyThingInContext $ showToHeader { ss_forall = @@ -1400,9 +1409,10 @@ extra_info ] -instMisMatch :: DFunId -> SDoc +instMisMatch :: DFunId -> TcRnMessage instMisMatch dfun - = hang (text "instance" <+> ppr (idType dfun)) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "instance" <+> ppr (idType dfun)) 2 (text "is defined in the hs-boot file, but not in the module itself") {- @@ -1590,7 +1600,9 @@ ; traceTc "tcPreludeClashWarn/prelude_functions" (hang (ppr name) 4 (sep [ppr clashingElts])) - ; let warn_msg x = addDiagnosticAt (WarningWithFlag warnFlag) (nameSrcSpan (greMangledName x)) (hsep + ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ + TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep [ text "Local definition of" , (quotes . ppr . nameOccName . greMangledName) x , text "clashes with a future Prelude name." ] @@ -1701,7 +1713,8 @@ -- " e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst warnMsg (KnownTc name:_) = - addDiagnosticAt (WarningWithFlag warnFlag) instLoc $ + addDiagnosticAt instLoc $ + TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" , (ppr . nameOccName . className) isClass @@ -1835,7 +1848,8 @@ -- in other modes, add error message and go on with typechecking. noMainMsg main_mod main_occ - = text "The" <+> ppMainFn main_occ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "The" <+> ppMainFn main_occ <+> text "is not" <+> text defOrExp <+> text "module" <+> quotes (ppr main_mod) @@ -2136,7 +2150,8 @@ zonked_expr <- zonkTopLExpr tc_expr ; zonked_ids <- zonkTopBndrs bound_ids ; - failIfErrsM ; -- we can't do the next step if there are levity polymorphism errors + failIfErrsM ; -- we can't do the next step if there are + -- representation polymorphism errors -- test case: ghci/scripts/T13202{,a} -- None of the Ids should be of unboxed type, because we @@ -2174,7 +2189,8 @@ return (global_ids, zonked_expr, fix_env) } where - bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", + bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (sep [text "GHCi can't bind a variable of unlifted type:", nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) {- @@ -2522,8 +2538,8 @@ _ <- tcLookupInstance ghciClass [userTy] return name - Just _ -> failWithTc $ text "Ambiguous type!" - Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + Just _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) -- | How should we infer a type? See Note [TcRnExprMode] data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) @@ -2610,7 +2626,7 @@ tcRnImportDecls hsc_env import_decls = runTcInteractive hsc_env $ do { gbl_env <- updGblEnv zap_rdr_env $ - tcRnImports hsc_env import_decls + tcRnImports hsc_env $ map (,text "is directly imported") import_decls ; return (tcg_rdr_env gbl_env) } where zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } @@ -2796,7 +2812,8 @@ let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) + ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) @@ -2910,11 +2927,11 @@ tcDump :: TcGblEnv -> TcRn () tcDump env - = do { dflags <- getDynFlags ; - unit_state <- hsc_units <$> getTopEnv ; + = do { unit_state <- hsc_units <$> getTopEnv ; + logger <- getLogger ; -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) (dumpTcRn True Opt_D_dump_types "" FormatText (pprWithUnitState unit_state short_dump)) ; @@ -3147,10 +3164,7 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ recordUnsafeInfer pluginUnsafe where - unsafeText = "Use of plugins makes the module unsafe" + !diag_opts = initDiagOpts dflags pluginUnsafe = singleMessage $ - mkPlainMsgEnvelope dflags noSrcSpan $ - TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints $ - Outputable.text unsafeText + mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot --- a/compiler/GHC/Tc/Module.hs-boot +++ b/compiler/GHC/Tc/Module.hs-boot @@ -2,11 +2,11 @@ import GHC.Prelude import GHC.Types.TyThing(TyThing) +import GHC.Tc.Errors.Types (TcRnMessage) import GHC.Tc.Types (TcM) -import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name) checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: Bool -> Name -> Name -> SDoc +missingBootThing :: Bool -> Name -> String -> TcRnMessage +badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -39,6 +39,7 @@ import GHC.Builtin.Utils import GHC.Builtin.Names import GHC.Tc.Errors +import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Solver.Interact import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) @@ -1343,10 +1344,10 @@ mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs -- Warn about the monomorphism restriction - ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ - diagnosticTc (WarningWithFlag Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg + ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do + let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMonomorphism) noHints mr_msg + diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia ; traceTc "decideMonoTyVars" $ vcat [ text "infer_mode =" <+> ppr infer_mode @@ -1794,7 +1795,8 @@ -- Typically if we blow the limit we are going to report some other error -- (an unsolved constraint), and we don't want that error to suppress -- the iteration limit warning! - addErrTcS (hang (text "solveWanteds: too many iterations" + addErrTcS $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "solveWanteds: too many iterations" <+> parens (text "limit =" <+> ppr limit)) 2 (vcat [ text "Unsolved:" <+> ppr wc , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -4,7 +4,7 @@ module GHC.Tc.Solver.Canonical( canonicalize, - unifyDerived, unifyTest, UnifyTestResult(..), + unifyDerived, makeSuperClasses, StopOrContinue(..), stopWith, continueWith, andWhenContinue, solveCallStack -- For GHC.Tc.Solver @@ -40,7 +40,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Builtin.Types ( anyTypeOfKind ) -import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs.Type( HsIPName(..) ) @@ -51,8 +50,7 @@ import GHC.Utils.Monad import Control.Monad import Data.Maybe ( isJust, isNothing ) -import Data.List ( zip4, partition ) -import GHC.Types.Unique.Set( nonDetEltsUniqSet ) +import Data.List ( zip4 ) import GHC.Types.Basic import Data.Bifunctor ( bimap ) @@ -724,7 +722,7 @@ do traceTcS "canEvNC:forall" (ppr pred) canForAllNC ev tvs th p IrredPred {} -> continueWith $ - mkIrredCt OtherCIS new_ev } } + mkIrredCt IrredShapeReason new_ev } } {- ********************************************************************* * * @@ -1094,8 +1092,8 @@ can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) ; case eq_rel of -- See Note [Unsolved equalities] - ReprEq -> continueWith (mkIrredCt OtherCIS ev) - NomEq -> continueWith (mkIrredCt InsolubleCIS ev) } + ReprEq -> continueWith (mkIrredCt ReprEqReason ev) + NomEq -> continueWith (mkIrredCt ShapeMismatchReason ev) } -- No need to call canEqFailure/canEqHardFailure because they -- rewrite, and the types involved here are already rewritten @@ -1575,10 +1573,10 @@ then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 else canEqFailure ev eq_rel ty1 ty2 } - -- See Note [Skolem abstract data] (at tyConSkolem) + -- See Note [Skolem abstract data] in GHC.Core.Tycon | tyConSkolem tc1 || tyConSkolem tc2 = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; continueWith (mkIrredCt OtherCIS ev) } + ; continueWith (mkIrredCt AbstractTyConReason ev) } -- Fail straight away for better error messages -- See Note [Use canEqFailure in canDecomposableTyConApp] @@ -1920,7 +1918,7 @@ ; traceTcS "canEqFailure with ReprEq" $ vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; continueWith (mkIrredCt OtherCIS new_ev) } + ; continueWith (mkIrredCt ReprEqReason new_ev) } -- | Call when canonicalizing an equality fails with utterly no hope. canEqHardFailure :: CtEvidence @@ -1931,7 +1929,7 @@ ; (s1, co1) <- rewrite ev ty1 ; (s2, co2) <- rewrite ev ty2 ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 - ; continueWith (mkIrredCt InsolubleCIS new_ev) } + ; continueWith (mkIrredCt ShapeMismatchReason new_ev) } {- Note [Decomposing TyConApps] @@ -2015,22 +2013,6 @@ types in canEqCanLHS *and* having the newtype-unwrapping check above the tyvar check in can_eq_nc. -Note [Occurs check error] -~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an occurs check error, are we necessarily hosed? Say our -tyvar is tv1 and the type it appears in is xi2. Because xi2 is function -free, then if we're computing w.r.t. nominal equality, then, yes, we're -hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. -representational equality, this is a little subtler. Once again, (a ~R [a]) -is a bad thing, but (a ~R N a) for a newtype N might be just fine. This -means also that (a ~ b a) might be fine, because `b` might become a newtype. - -So, we must check: does tv1 appear in xi2 under any type constructor -that is generative w.r.t. representational equality? That's what -isInsolubleOccursCheck does. - -See also #10715, which induced this addition. - Note [Put touchable variables on the left] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticket #10009, a very nasty example: @@ -2254,10 +2236,10 @@ -- If we have F a ~ F (F a), we want to swap. swap_for_occurs - | CTE_OK <- checkTyFamEq dflags fun_tc2 fun_args2 - (mkTyConApp fun_tc1 fun_args1) - , CTE_Occurs <- checkTyFamEq dflags fun_tc1 fun_args1 - (mkTyConApp fun_tc2 fun_args2) + | cterHasNoProblem $ checkTyFamEq dflags fun_tc2 fun_args2 + (mkTyConApp fun_tc1 fun_args1) + , cterHasOccursCheck $ checkTyFamEq dflags fun_tc1 fun_args1 + (mkTyConApp fun_tc2 fun_args2) = True | otherwise @@ -2299,10 +2281,11 @@ -> MCoercion -- :: kind(rhs) ~N kind(lhs) -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco - = do { can_unify <- unifyTest ev tv1 rhs - ; dflags <- getDynFlags - ; if | case can_unify of { NoUnify -> False; _ -> True } - , CTE_OK <- checkTyVarEq dflags YesTypeFamilies tv1 rhs + = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs + ; dflags <- getDynFlags + ; if | case is_touchable of { Untouchable -> False; _ -> True } + , cterHasNoProblem $ + checkTyVarEq dflags tv1 rhs `cterRemoveProblem` cteTypeFamily -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs | otherwise @@ -2316,82 +2299,6 @@ sym_mco = mkTcSymMCo mco rhs = ps_xi2 `mkCastTyMCo` mco -data UnifyTestResult - -- See Note [Solve by unification] in GHC.Tc.Solver.Interact - -- which points out that having UnifySameLevel is just an optimisation; - -- we could manage with UnifyOuterLevel alone (suitably renamed) - = UnifySameLevel - | UnifyOuterLevel [TcTyVar] -- Promote these - TcLevel -- ..to this level - | NoUnify - -instance Outputable UnifyTestResult where - ppr UnifySameLevel = text "UnifySameLevel" - ppr (UnifyOuterLevel tvs lvl) = text "UnifyOuterLevel" <> parens (ppr lvl <+> ppr tvs) - ppr NoUnify = text "NoUnify" - -unifyTest :: CtEvidence -> TcTyVar -> TcType -> TcS UnifyTestResult --- This is the key test for untouchability: --- See Note [Unification preconditions] in GHC.Tc.Utils.Unify --- and Note [Solve by unification] in GHC.Tc.Solver.Interact -unifyTest ev tv1 rhs - | not (isGiven ev) -- See Note [Do not unify Givens] - , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1 - , canSolveByUnification info rhs - = do { ambient_lvl <- getTcLevel - ; given_eq_lvl <- getInnermostGivenEqLevel - - ; if | tv_lvl `sameDepthAs` ambient_lvl - -> return UnifySameLevel - - | tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities - , all (does_not_escape tv_lvl) free_skols -- No skolem escapes - -> return (UnifyOuterLevel free_metas tv_lvl) - - | otherwise - -> return NoUnify } - | otherwise - = return NoUnify - where - (free_metas, free_skols) = partition isPromotableMetaTyVar $ - nonDetEltsUniqSet $ - tyCoVarsOfType rhs - - does_not_escape tv_lvl fv - | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv - | otherwise = True - -- Coercion variables are not an escape risk - -- If an implication binds a coercion variable, it'll have equalities, - -- so the "intervening given equalities" test above will catch it - -- Coercion holes get filled with coercions, so again no problem. - -{- Note [Do not unify Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GADT match - data T a where - T1 :: T Int - ... - - f x = case x of - T1 -> True - ... - -So we get f :: T alpha[1] -> beta[1] - x :: T alpha[1] -and from the T1 branch we get the implication - forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool - -Now, clearly we don't want to unify alpha:=Int! Yet at the moment we -process [G] alpha[1] ~ Int, we don't have any given-equalities in the -inert set, and hence there are no given equalities to make alpha untouchable. - -NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that -never happens: invariant (GivenInv) in Note [TcLevel invariants] -in GHC.Tc.Utils.TcType. - -Simple solution: never unify in Givens! --} - -- The RHS here is either not CanEqLHS, or it's one that we -- want to rewrite the LHS to (as per e.g. swapOverTyVars) canEqCanLHSFinish :: CtEvidence @@ -2403,52 +2310,71 @@ -- RHS is fully rewritten, but with type synonyms -- preserved as much as possible -- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) --- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo +-- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 = do { dflags <- getDynFlags ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2 + -- by now, (TyEq:K) is already satisfied + ; massert (canEqLHSKind lhs `eqType` tcTypeKind rhs) + + -- by now, (TyEq:N) is already satisfied (if applicable) + ; massert (not bad_newtype) + + -- guarantees (TyEq:OC), (TyEq:F) -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...) - -- #12593 - -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H) - -- this next line checks also for coercion holes (TyEq:H); see - -- Note [Equalities with incompatible kinds] - ; case canEqOK dflags eq_rel lhs rhs of - CanEqOK -> - do { traceTcS "canEqOK" (ppr lhs $$ ppr rhs) - ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs - , cc_rhs = rhs, cc_eq_rel = eq_rel }) } - -- it is possible that cc_rhs mentions the LHS if the LHS is a type - -- family. This will cause later rewriting to potentially loop, but - -- that will be caught by the depth counter. The other option is an - -- occurs-check for a function application, which seems awkward. + -- equalities, in case have x ~ (y :: ..x...); this is #12593. + -- This next line checks also for coercion holes (TyEq:H); see + -- Note [Equalities with incompatible kinds] + ; let result0 = checkTypeEq dflags lhs rhs `cterRemoveProblem` cteTypeFamily + -- type families are OK here + -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite - CanEqNotOK status - -- See Note [Type variable cycles in Givens] - | OtherCIS <- status - , Given <- ctEvFlavour ev - , TyVarLHS lhs_tv <- lhs - , not (isCycleBreakerTyVar lhs_tv) -- See Detail (7) of Note - , NomEq <- eq_rel - -> do { traceTcS "canEqCanLHSFinish breaking a cycle" (ppr lhs $$ ppr rhs) - ; new_rhs <- breakTyVarCycle (ctEvLoc ev) rhs - ; traceTcS "new RHS:" (ppr new_rhs) - ; let new_pred = mkPrimEqPred (mkTyVarTy lhs_tv) new_rhs - new_new_ev = new_ev { ctev_pred = new_pred } - -- See Detail (6) of Note [Type variable cycles in Givens] - ; if anyRewritableTyVar True NomEq (\ _ tv -> tv == lhs_tv) new_rhs - then do { traceTcS "Note [Type variable cycles in Givens] Detail (1)" - (ppr new_new_ev) - ; continueWith (mkIrredCt status new_ev) } - else continueWith (CEqCan { cc_ev = new_new_ev, cc_lhs = lhs - , cc_rhs = new_rhs, cc_eq_rel = eq_rel }) } + -- a ~R# b a is soluble if b later turns out to be Identity + result = case eq_rel of + NomEq -> result0 + ReprEq -> cterSetOccursCheckSoluble result0 - -- We must not use it for further rewriting! - | otherwise - -> do { traceTcS "canEqCanLHSFinish can't make a canonical" (ppr lhs $$ ppr rhs) - ; continueWith (mkIrredCt status new_ev) } } + reason | result `cterHasOnlyProblem` cteHoleBlocker + = HoleBlockerReason (coercionHolesOfType rhs) + | otherwise + = NonCanonicalReason result + + ; if cterHasNoProblem result + then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs) + ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs + , cc_rhs = rhs, cc_eq_rel = eq_rel }) } + + else do { m_stuff <- breakTyVarCycle_maybe ev result lhs rhs + -- See Note [Type variable cycles]; + -- returning Nothing is the vastly common case + ; case m_stuff of + { Nothing -> + do { traceTcS "canEqCanLHSFinish can't make a canonical" + (ppr lhs $$ ppr rhs) + ; continueWith (mkIrredCt reason new_ev) } + ; Just (lhs_tv, co, new_rhs) -> + do { traceTcS "canEqCanLHSFinish breaking a cycle" $ + ppr lhs $$ ppr rhs + ; traceTcS "new RHS:" (ppr new_rhs) + + -- This check is Detail (1) in the Note + ; if cterHasOccursCheck (checkTyVarEq dflags lhs_tv new_rhs) + + then do { traceTcS "Note [Type variable cycles] Detail (1)" + (ppr new_rhs) + ; continueWith (mkIrredCt reason new_ev) } + + else do { -- See Detail (6) of Note [Type variable cycles] + new_new_ev <- rewriteEqEvidence new_ev NotSwapped + lhs_ty new_rhs + (mkTcNomReflCo lhs_ty) co + + ; continueWith (CEqCan { cc_ev = new_new_ev + , cc_lhs = lhs + , cc_rhs = new_rhs + , cc_eq_rel = eq_rel }) }}}}} where role = eqRelRole eq_rel @@ -2457,6 +2383,13 @@ rewrite_co1 = mkTcReflCo role lhs_ty rewrite_co2 = mkTcReflCo role rhs + -- This is about (TyEq:N) + bad_newtype | ReprEq <- eq_rel + , Just tc <- tyConAppTyCon_maybe rhs + = isNewTyCon tc + | otherwise + = False + -- | Solve a reflexive equality constraint canEqReflexive :: CtEvidence -- ty ~ ty -> EqRel @@ -2486,77 +2419,6 @@ sym_mco = mkTcSymMCo mco role = eqRelRole eq_rel ---------------------------------------------- --- | Result of checking whether a RHS is suitable for pairing --- with a CanEqLHS in a CEqCan. -data CanEqOK - = CanEqOK -- RHS is good - | CanEqNotOK CtIrredStatus -- don't proceed; explains why - -instance Outputable CanEqOK where - ppr CanEqOK = text "CanEqOK" - ppr (CanEqNotOK status) = text "CanEqNotOK" <+> ppr status - --- | This function establishes most of the invariants needed to make --- a CEqCan. --- --- TyEq:OC: Checked here. --- TyEq:F: Checked here. --- TyEq:K: assumed; ASSERTed here (that is, kind(lhs) = kind(rhs)) --- TyEq:N: assumed; ASSERTed here (if eq_rel is R, rhs is not a newtype) --- TyEq:TV: not checked (this is hard to check) --- TyEq:H: Checked here. -canEqOK :: DynFlags -> EqRel -> CanEqLHS -> Xi -> CanEqOK -canEqOK dflags eq_rel lhs rhs - = assert good_rhs $ - case checkTypeEq dflags YesTypeFamilies lhs rhs of - CTE_OK -> CanEqOK - CTE_Bad -> CanEqNotOK OtherCIS - -- Violation of TyEq:F - - CTE_HoleBlocker -> CanEqNotOK (BlockedCIS holes) - where holes = coercionHolesOfType rhs - -- This is the case detailed in - -- Note [Equalities with incompatible kinds] - -- Violation of TyEq:H - - -- These are both a violation of TyEq:OC, but we - -- want to differentiate for better production of - -- error messages - CTE_Occurs | TyVarLHS tv <- lhs - , isInsolubleOccursCheck eq_rel tv rhs -> CanEqNotOK InsolubleCIS - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - - -- NB: no occCheckExpand here; see Note [Rewriting synonyms] - -- in GHC.Tc.Solver.Rewrite - - | otherwise -> CanEqNotOK OtherCIS - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - - -- This case also include type family occurs-check errors, which - -- are not generally insoluble - - where - good_rhs = kinds_match && not bad_newtype - - lhs_kind = canEqLHSKind lhs - rhs_kind = tcTypeKind rhs - - kinds_match = lhs_kind `tcEqType` rhs_kind - - bad_newtype | ReprEq <- eq_rel - , Just tc <- tyConAppTyCon_maybe rhs - = isNewTyCon tc - | otherwise - = False - {- Note [Equalities with incompatible kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What do we do when we have an equality @@ -2583,7 +2445,7 @@ until the kind-equality on which it depends (namely 'co' above) is solved. To achieve this * The [X] constraint is a CIrredCan -* With a cc_status of BlockedCIS bchs +* With a cc_reason of HoleBlockerReason bchs * Where 'bchs' is the set of "blocking coercion holes". The blocking coercion holes are the free coercion holes of [X]'s type * When all the blocking coercion holes in the CIrredCan are filled (solved), @@ -2608,14 +2470,15 @@ So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have any coercion holes. This is checked in checkTypeEq. Any equalities that - have such an RHS are turned into CIrredCans with a BlockedCIS status. We also + have such an RHS are turned into CIrredCans with a HoleBlockerReason. We also must be sure to kick out any such CIrredCan constraints that mention coercion holes when those holes get filled in, so that the unification step can now proceed. - The kicking out is done in kickOutAfterFillingCoercionHole. + The kicking out is done in kickOutAfterFillingCoercionHole, and the inerts + are stored in the inert_blocked field of InertCans. However, we must be careful: we kick out only when no coercion holes are - left. The holes in the type are stored in the BlockedCIS CtIrredStatus. + left. The holes in the type are stored in the HoleBlockerReason CtIrredReason. The extra check that there are no more remaining holes avoids needless work when rewriting evidence (which fills coercion holes) and aids efficiency. @@ -2658,7 +2521,7 @@ cast appears opposite a tyvar. This is implemented in the cast case of can_eq_nc'. - (4) Reporting an error for a constraint that is blocked with status BlockedCIS + (4) Reporting an error for a constraint that is blocked with HoleBlockerReason is hard: what would we say to users? And we don't really need to report, because if a constraint is blocked, then there is unsolved wanted blocking it; that unsolved wanted will @@ -2668,7 +2531,7 @@ (4a) It would seem possible to do this filtering just based on the presence of a blocking coercion hole. However, this is no good, as it suppresses e.g. no-instance-found errors. We thus record - a CtIrredStatus in CIrredCan and filter based on this status. + a CtIrredReason in CIrredCan and filter based on this status. This happened in T14584. An alternative approach is to expressly look for *equalities* with blocking coercion holes, but actually recording the blockage in a status field seems nicer. @@ -2725,53 +2588,70 @@ good error messages we want to leave type synonyms unexpanded as much as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. -Note [Type variable cycles in Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Type variable cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this situation (from indexed-types/should_compile/GivenLoop): instance C (Maybe b) - [G] a ~ Maybe (F a) + *[G] a ~ Maybe (F a) [W] C a -In order to solve the Wanted, we must use the Given to rewrite `a` to -Maybe (F a). But note that the Given has an occurs-check failure, and -so we can't straightforwardly add the Given to the inert set. +or (typecheck/should_compile/T19682b): -The key idea is to replace the (F a) in the RHS of the Given with a -fresh variable, which we'll call a CycleBreakerTv, or cbv. Then, emit -a new Given to connect cbv with F a. So our situation becomes + instance C (a -> b) + *[WD] alpha ~ (Arg alpha -> Res alpha) + [W] C alpha +In order to solve the final Wanted, we must use the starred constraint +for rewriting. But note that both starred constraints have occurs-check failures, +and so we can't straightforwardly add these to the inert set and +use them for rewriting. (NB: A rigid type constructor is at the +top of both RHSs. If the type family were at the top, we'd just reorient +in canEqTyVarFunEq.) + +The key idea is to replace the type family applications in the RHS of the +starred constraints with a fresh variable, which we'll call a cycle-breaker +variable, or cbv. Then, relate the cbv back with the original type family application +via new equality constraints. Our situations thus become: + instance C (Maybe b) [G] a ~ Maybe cbv [G] F a ~ cbv [W] C a -Note the orientation of the second Given. The type family ends up -on the left; see commentary on canEqTyVarFunEq, which decides how to -orient such cases. 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. +or -(The first Given actually also rewrites the second one. This causes -no trouble.) + instance C (a -> b) + [WD] alpha ~ (cbv1 -> cbv2) + [WD] Arg alpha ~ cbv1 + [WD] Res alpha ~ cbv2 + [W] C alpha -More generally, we detect this scenario by the following characteristics: - - a Given CEqCan constraint - - with a tyvar on its LHS - - with a soluble occurs-check failure - - and a nominal equality +This transformation (creating the new types and emitting new equality +constraints) is done in breakTyVarCycle_maybe. -Having identified the scenario, we wish to replace all type family -applications on the RHS with fresh metavariables (with MetaInfo -CycleBreakerTv). This is done in breakTyVarCycle. These metavariables are -untouchable, but we also emit Givens relating the fresh variables to the type -family applications they replace. +The details depend on whether we're working with a Given or a Derived. +(Note that the Wanteds are really WDs, above. This is because Wanteds +are not used for rewriting.) +Given +----- + +We emit a new Given, [G] F a ~ cbv, equating the type family application to +our new cbv. Note its orientation: The type family ends up on the left; see +commentary on canEqTyVarFunEq, which decides how to orient such cases. 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. + +(The first Given actually also rewrites the second one, giving +[G] F (Maybe cbv) ~ cbv, but this causes no trouble.) + Of course, we don't want our fresh variables leaking into e.g. error messages. So we fill in the metavariables with their original type family applications after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds). This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in -InertSet, which contains the pairings invented in breakTyVarCycle. +InertSet, which contains the pairings invented in breakTyVarCycle_maybe. That is: @@ -2796,27 +2676,124 @@ * The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is ultimately going to happen. -There are drawbacks of this approach: +Wanted/Derived +-------------- +The fresh cycle-breaker variables here must actually be normal, touchable +metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating +the example from above, we have - 1. We apply this trick only for Givens, never for Wanted or Derived. - It wouldn't make sense for Wanted, because Wanted never rewrite. - But it's conceivable that a Derived would benefit from this all. - I doubt it would ever happen, though, so I'm holding off. + *[WD] alpha ~ (Arg alpha -> Res alpha) - 2. We don't use this trick for representational equalities, as there - is no concrete use case where it is helpful (unlike for nominal - equalities). Furthermore, because function applications can be - CanEqLHSs, but newtype applications cannot, the disparities between - the cases are enough that it would be effortful to expand the idea - to representational equalities. A quick attempt, with +and we turn this into + *[WD] alpha ~ (cbv1 -> cbv2) + [WD] Arg alpha ~ cbv1 + [WD] Res alpha ~ cbv2 + +where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. + +Critically, we emit the constraint directly instead of calling unifyWanted. +Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This +unification happens in the course of normal behavior of top-level +interactions, later in the solver pipeline. We know this unification will +indeed happen, because breakTyVarCycle_maybe, which decides whether to apply +this logic, goes to pains to make sure unification will succeed. Now, we're +here (including further context from our original example, from the top of the +Note): + + instance C (a -> b) + [WD] Arg (cbv1 -> cbv2) ~ cbv1 + [WD] Res (cbv1 -> cbv2) ~ cbv2 + [W] C (cbv1 -> cbv2) + +The first two WD constraints reduce to reflexivity and are discarded, +and the last is easily soluble. + +[Why TauTvs]: +Let's look at another example (typecheck/should_compile/T19682) where we need +to unify the cbvs: + + class (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + + type family SameShapeAs xs ys :: Constraint where + SameShapeAs '[] ys = (ys ~ '[]) + SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys)) + + type family AllEqF xs ys :: Constraint where + AllEqF '[] '[] = () + AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) + + [WD] alpha ~ (Head alpha : Tail alpha) + [WD] AllEqF '[Bool] alpha + +Without the logic detailed in this Note, we're stuck here, as AllEqF cannot +reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, +just as described above. We thus invent cbv1 and cbv2 and unify +alpha := cbv1 -> cbv2, yielding (after zonking) + + [WD] Head (cbv1 : cbv2) ~ cbv1 + [WD] Tail (cbv1 : cbv2) ~ cbv2 + [WD] AllEqF '[Bool] (cbv1 : cbv2) + +The first two WD constraints simplify to reflexivity and are discarded. +But the last reduces: + + [WD] Bool ~ cbv1 + [WD] AllEq '[] cbv2 + +The first of these is solved by unification: cbv1 := Bool. The second +is solved by the instance for AllEq to become + + [WD] AllEqF '[] cbv2 + [WD] SameShapeAs '[] cbv2 + +While the first of these is stuck, the second makes progress, to lead to + + [WD] AllEqF '[] cbv2 + [WD] cbv2 ~ '[] + +This second constraint is solved by unification: cbv2 := '[]. We now +have + + [WD] AllEqF '[] '[] + +which reduces to + + [WD] () + +which is trivially satisfiable. Hooray! + +Note that we need to unify the cbvs here; if we did not, there would be +no way to solve those constraints. That's why the cycle-breakers are +ordinary TauTvs. + +In all cases +------------ + +We detect this scenario by the following characteristics: + - a constraint with a tyvar on its LHS + - with a soluble occurs-check failure + - and a nominal equality + - and either + - a Given flavour (but see also Detail (7) below) + - a Wanted/Derived or just plain Derived flavour, with a touchable metavariable + on the left + +We don't use this trick for representational equalities, as there is no +concrete use case where it is helpful (unlike for nominal equalities). +Furthermore, because function applications can be CanEqLHSs, but newtype +applications cannot, the disparities between the cases are enough that it +would be effortful to expand the idea to representational equalities. A quick +attempt, with + data family N a b f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b f = coerce - failed with "Could not match 'b' with 'b'." Further work is held off - until when we have a concrete incentive to explore this dark corner. +failed with "Could not match 'b' with 'b'." Further work is held off +until when we have a concrete incentive to explore this dark corner. Details: @@ -2828,17 +2805,21 @@ type family, or that outer type family application would already have been substituted away. - However, we still must check to make sure that breakTyVarCycle actually - succeeds in getting rid of all occurrences of the offending variable. - If one is hidden under a forall, this won't be true. So we perform - an additional check after performing the substitution. + However, we still must check to make sure that breakTyVarCycle_maybe actually + succeeds in getting rid of all occurrences of the offending variable. If + one is hidden under a forall, this won't be true. A similar problem can + happen if the variable appears only in a kind + (e.g. k ~ ... (a :: k) ...). So we perform an additional check after + performing the substitution. It is tiresome to re-run all of checkTyVarEq + here, but reimplementing just the occurs-check is even more tiresome. - Skipping this check causes typecheck/should_fail/GivenForallLoop to loop. + Skipping this check causes typecheck/should_fail/GivenForallLoop and + polykinds/T18451 to loop. (2) Our goal here is to avoid loops in rewriting. We can thus skip looking - in coercions, as we don't rewrite in coercions. - (There is no worry about unifying a meta-variable here: this Note is - only about Givens.) + in coercions, as we don't rewrite in coercions. (This is another reason + we need to re-check that we've gotten rid of all occurrences of the + offending variable.) (3) As we're substituting, we can build ill-kinded types. For example, if we have Proxy (F a) b, where (b :: F a), then @@ -2868,21 +2849,18 @@ Note [Flattening type-family applications when matching instances] in GHC.Core.Unify, which goes to this extra effort.) There may be other opportunities for - improvement. However, this is really a very small corner case, always - tickled by a user-written Given. The investment to craft a clever, + improvement. However, this is really a very small corner case. + The investment to craft a clever, performant solution seems unworthwhile. (6) We often get the predicate associated with a constraint from its evidence. We thus must not only make sure the generated CEqCan's fields have the updated RHS type, but we must also update the - evidence itself. As in Detail (4), we don't need to change the - evidence term (as in e.g. rewriteEqEvidence) because the cycle - breaker variables are all zonked away by the time we examine the - evidence. That is, we must set the ctev_pred of the ctEvidence. - This is implemented in canEqCanLHSFinish, with a reference to - this detail. + evidence itself. This is done by the call to rewriteEqEvidence + in canEqCanLHSFinish. - (7) We don't wish to apply this magic to CycleBreakerTvs themselves. + (7) We don't wish to apply this magic on the equalities created + by this very same process. Consider this, from typecheck/should_compile/ContextStack2: type instance TF (a, b) = (TF a, TF b) @@ -2913,23 +2891,19 @@ unchecked, this will end up breaking cycles again, looping ad infinitum (and resulting in a context-stack reduction error, not an outright loop). The solution is easy: don't break cycles - if the var is already a CycleBreakerTv. Instead, we mark this - final Given as a CIrredCan with an OtherCIS status (it's not - insoluble). - - NB: When filling in CycleBreakerTvs, we fill them in with what - they originally stood for (e.g. cbv1 := TF a, cbv2 := TF Int), - not what may be in a rewritten constraint. - - Not breaking cycles further (which would mean changing TF cbv1 to cbv3 - and TF cbv2 to cbv4) makes sense, because we only want to break cycles - for user-written loopy Givens, and a CycleBreakerTv certainly isn't - user-written. + on an equality generated by breaking cycles. Instead, we mark this + final Given as a CIrredCan with a NonCanonicalReason with the soluble + occurs-check bit set (only). -NB: This same situation (an equality like b ~ Maybe (F b)) can arise with -Wanteds, but we have no concrete case incentivising special treatment. It -would just be a CIrredCan. + We track these equalities by giving them a special CtOrigin, + CycleBreakerOrigin. This works for both Givens and WDs, as + we need the logic in the WD case for e.g. typecheck/should_fail/T17139. + (8) We really want to do this all only when there is a soluble occurs-check + failure, not when other problems arise (such as an impredicative + equality like alpha ~ forall a. a -> a). That is why breakTyVarCycle_maybe + uses cterHasOnlyProblem when looking at the result of checkTypeEq, which + checks for many of the invariants on a CEqCan. -} {- diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs deleted file mode 100644 --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ /dev/null @@ -1,1633 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Tc.Solver.InertSet ( - -- * The work list - WorkList(..), isEmptyWorkList, emptyWorkList, - extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEq, extendWorkListDeriveds, - appendWorkList, extendWorkListImplic, - workListSize, - selectWorkItem, - - -- * The inert set - InertSet(..), - InertCans(..), - InertEqs, - emptyInert, - addInertItem, - - matchableGivens, - mightEqualLater, - prohibitedSuperClassSolve, - - -- * Inert equalities - foldTyEqs, delEq, findEq, - - -- * Kick-out - kickOutRewritableLHS - - ) where - -import GHC.Prelude - -import GHC.Tc.Solver.Types - -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType -import GHC.Types.Var -import GHC.Types.Var.Env - -import GHC.Core.Predicate -import GHC.Core.TyCo.FVs -import qualified GHC.Core.TyCo.Rep as Rep -import GHC.Core.TyCon -import GHC.Core.Unify - -import GHC.Data.Bag -import GHC.Utils.Misc ( chkAppend, partitionWith ) -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) - -{- -************************************************************************ -* * -* Worklists * -* Canonical and non-canonical constraints that the simplifier has to * -* work on. Including their simplification depths. * -* * -* * -************************************************************************ - -Note [WorkList priorities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavours). -Notice that each Ct now has a simplification depth. We may -consider using this depth for prioritization as well in the future. - -As a simple form of priority queue, our worklist separates out - -* equalities (wl_eqs); see Note [Prioritise equalities] -* all the rest (wl_rest) - -Note [Prioritise equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to process equalities /first/: - -* (Efficiency) The general reason to do so is that if we process a - class constraint first, we may end up putting it into the inert set - and then kicking it out later. That's extra work compared to just - doing the equality first. - -* (Avoiding fundep iteration) As #14723 showed, it's possible to - get non-termination if we - - Emit the Derived fundep equalities for a class constraint, - generating some fresh unification variables. - - That leads to some unification - - Which kicks out the class constraint - - Which isn't solved (because there are still some more Derived - equalities in the work-list), but generates yet more fundeps - Solution: prioritise derived equalities over class constraints - -* (Class equalities) We need to prioritise equalities even if they - are hidden inside a class constraint; - see Note [Prioritise class equalities] - -* (Kick-out) We want to apply this priority scheme to kicked-out - constraints too (see the call to extendWorkListCt in kick_out_rewritable - E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become - homo-kinded when kicked out, and hence we want to prioritise it. - -* (Derived equalities) Originally we tried to postpone processing - Derived equalities, in the hope that we might never need to deal - with them at all; but in fact we must process Derived equalities - eagerly, partly for the (Efficiency) reason, and more importantly - for (Avoiding fundep iteration). - -Note [Prioritise class equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prioritise equalities in the solver (see selectWorkItem). But class -constraints like (a ~ b) and (a ~~ b) are actually equalities too; -see Note [The equality types story] in GHC.Builtin.Types.Prim. - -Failing to prioritise these is inefficient (more kick-outs etc). -But, worse, it can prevent us spotting a "recursive knot" among -Wanted constraints. See comment:10 of #12734 for a worked-out -example. - -So we arrange to put these particular class constraints in the wl_eqs. - - NB: since we do not currently apply the substitution to the - inert_solved_dicts, the knot-tying still seems a bit fragile. - But this makes it better. - -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See GHC.Tc.Solver.Monad.deferTcSForAllEq - --} - --- See Note [WorkList priorities] -data WorkList - = WL { wl_eqs :: [Ct] -- CEqCan, CDictCan, CIrredCan - -- Given, Wanted, and Derived - -- Contains both equality constraints and their - -- class-level variants (a~b) and (a~~b); - -- See Note [Prioritise equalities] - -- See Note [Prioritise class equalities] - - , wl_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_rest = rest1 - , wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_rest = rest2 - , wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_rest = rest }) - = length eqs + length rest - -extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList -extendWorkListDeriveds evs wl - = extendWorkListCts (map mkNonCanonical evs) wl - -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic -extendWorkListCt ct wl - = case classifyPredType (ctPred ct) of - EqPred {} - -> extendWorkListEq ct wl - - ClassPred cls _ -- See Note [Prioritise class equalities] - | isEqPredClass cls - -> extendWorkListEq ct wl - - _ -> extendWorkListNonEq ct wl - -extendWorkListCts :: [Ct] -> WorkList -> WorkList --- Agnostic -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && isEmptyBag implics - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) --- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") - ]) - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -data InertSet - = IS { inert_cans :: InertCans - -- Canonical Given, Wanted, Derived - -- Sometimes called "the inert set" - - , inert_cycle_breakers :: [(TcTyVar, TcType)] - -- a list of CycleBreakerTv / original family applications - -- used to undo the cycle-breaking needed to handle - -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical - - , inert_famapp_cache :: FunEqMap (TcCoercion, TcType) - -- Just a hash-cons cache for use when reducing family applications - -- only - -- - -- If F tys :-> (co, rhs, flav), - -- then co :: rhs ~N F tys - -- all evidence is from instances or Givens; no coercion holes here - -- (We have no way of "kicking out" from the cache, so putting - -- wanteds here means we can end up solving a Wanted with itself. Bad) - - , inert_solved_dicts :: DictMap CtEvidence - -- All Wanteds, of form ev :: C t1 .. tn - -- See Note [Solved dictionaries] - -- and Note [Do not add superclasses of solved dictionaries] - } - -instance Outputable InertSet where - ppr (IS { inert_cans = ics - , inert_solved_dicts = solved_dicts }) - = vcat [ ppr ics - , ppUnless (null dicts) $ - text "Solved dicts =" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag solved_dicts) - -emptyInertCans :: InertCans -emptyInertCans - = IC { inert_eqs = emptyDVarEnv - , inert_given_eq_lvl = topTcLevel - , inert_given_eqs = False - , inert_dicts = emptyDictMap - , inert_safehask = emptyDictMap - , inert_funeqs = emptyFunEqs - , inert_insts = [] - , inert_irreds = emptyCts } - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans - , inert_cycle_breakers = [] - , inert_famapp_cache = emptyFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degenerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] - -VERY IMPORTANT INVARIANT: - - (Solved Dictionary Invariant) - Every member of the inert_solved_dicts is the result - of applying an instance declaration that "takes a step" - - An instance "takes a step" if it has the form - dfunDList d1 d2 = MkD (...) (...) (...) - That is, the dfun is lazy in its arguments, and guarantees to - immediately return a dictionary constructor. NB: all dictionary - data constructors are lazy in their arguments. - - This property is crucial to ensure that all dictionaries are - non-bottom, which in turn ensures that the whole "recursive - dictionary" idea works at all, even if we get something like - rec { d = dfunDList d dx } - See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. - - Reason: - - All instances, except two exceptions listed below, "take a step" - in the above sense - - - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when appling a quantified - constraint led to the ability to define unsafeCoerce - in #17267. - - - Exception 2: the magic built-in instance for (~) has no - such guarantee. It behaves as if we had - class (a ~# b) => (a ~ b) where {} - instance (a ~# b) => (a ~ b) where {} - The "dfun" for the instance is strict in the coercion. - Anyway there's no point in recording a "solved dict" for - (t1 ~ t2); it's not going to allow a recursive dictionary - to be constructed. Ditto (~~) and Coercible. - -THEREFORE we only add a "solved dictionary" - - when applying an instance declaration - - subject to Exceptions 1 and 2 above - -In implementation terms - - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary, - conditional on the kind of instance - - - It is only called when applying an instance decl, - in GHC.Tc.Solver.Interact.doTopReactDict - - - ClsInst.InstanceWhat says what kind of instance was - used to solve the constraint. In particular - * LocalInstance identifies quantified constraints - * BuiltinEqInstance identifies the strange built-in - instances for equality. - - - ClsInst.instanceReturnsDictCon says which kind of - instance guarantees to return a dictionary constructor - -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, - so it may get out of date. - -* The inert_solved_dicts are all Wanteds, never givens - -* We only cache dictionaries from top-level instances, not from - local quantified constraints. Reason: if we cached the latter - we'd need to purge the cache when bringing new quantified - constraints into scope, because quantified constraints "shadow" - top-level instances. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a -dictionary function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -{- Note [Tracking Given equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify -Note [Unification preconditions], we can't unify - alpha[2] ~ Int -under a level-4 implication if there are any Given equalities -bound by the implications at level 3 of 4. To that end, the -InertCans tracks - - inert_given_eq_lvl :: TcLevel - -- The TcLevel of the innermost implication that has a Given - -- equality of the sort that make a unification variable untouchable - -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). - -We update inert_given_eq_lvl whenever we add a Given to the -inert set, in updateGivenEqs. - -Then a unification variable alpha[n] is untouchable iff - n < inert_given_eq_lvl -that is, if the unification variable was born outside an -enclosing Given equality. - -Exactly which constraints should trigger (UNTOUCHABLE), and hence -should update inert_given_eq_lvl? - -* We do /not/ need to worry about let-bound skolems, such ast - forall[2] a. a ~ [b] => blah - See Note [Let-bound skolems] - -* Consider an implication - forall[2]. beta[1] => alpha[1] ~ Int - where beta is a unification variable that has already been unified - to () in an outer scope. Then alpha[1] is perfectly touchable and - we can unify alpha := Int. So when deciding whether the givens contain - an equality, we should canonicalise first, rather than just looking at - the /original/ givens (#8644). - - * However, we must take account of *potential* equalities. Consider the - same example again, but this time we have /not/ yet unified beta: - forall[2] beta[1] => ...blah... - - Because beta might turn into an equality, updateGivenEqs conservatively - treats it as a potential equality, and updates inert_give_eq_lvl - - * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z? - - That Given cannot affect the Wanted, because the Given is entirely - *local*: it mentions only skolems bound in the very same - implication. Such equalities need not make alpha untouchable. (Test - case typecheck/should_compile/LocalGivenEqs has a real-life - motivating example, with some detailed commentary.) - Hence the 'mentionsOuterVar' test in updateGivenEqs. - - However, solely to support better error messages - (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track - these "local" equalities in the boolean inert_given_eqs field. - This field is used only to set the ic_given_eqs field to LocalGivenEqs; - see the function getHasGivenEqs. - - Here is a simpler case that triggers this behaviour: - - data T where - MkT :: F a ~ G b => a -> b -> T - - f (MkT _ _) = True - - Because of this behaviour around local equality givens, we can infer the - type of f. This is typecheck/should_compile/LocalGivenEqs2. - - * We need not look at the equality relation involved (nominal vs - representational), because representational equalities can still - imply nominal ones. For example, if (G a ~R G b) and G's argument's - role is nominal, then we can deduce a ~N b. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. - -For an example, see #9211. - -See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure -that the right variable is on the left of the equality when both are -tyvars. - -You might wonder whether the skolem really needs to be bound "in the -very same implication" as the equuality constraint. -Consider this (c.f. #15009): - - data S a where - MkS :: (a ~ Int) => S a - - g :: forall a. S a -> a -> blah - g x y = let h = \z. ( z :: Int - , case x of - MkS -> [y,z]) - in ... - -From the type signature for `g`, we get `y::a` . Then when we -encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the -body of the lambda we'll get - - [W] alpha[1] ~ Int -- From z::Int - [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] - -Now, unify alpha := a. Now we are stuck with an unsolved alpha~Int! -So we must treat alpha as untouchable under the forall[2] implication. - -Note [Detailed InertCans Invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The InertCans represents a collection of constraints with the following properties: - - * All canonical - - * No two dictionaries with the same head - * No two CIrreds with the same type - - * Family equations inert wrt top-level family axioms - - * Dictionaries have no matching top-level instance - - * Given family or dictionary constraints don't mention touchable - unification variables - - * Non-CEqCan constraints are fully rewritten with respect - to the CEqCan equalities (modulo eqCanRewrite of course; - eg a wanted cannot rewrite a given) - - * CEqCan equalities: see Note [inert_eqs: the inert equalities] - Also see documentation in Constraint.Ct for a list of invariants - -Note [inert_eqs: the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definition [Can-rewrite relation] -A "can-rewrite" relation between flavours, written f1 >= f2, is a -binary relation with the following properties - - (R1) >= is transitive - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 - (See Note [Why R2?].) - -Lemma (L0). If f1 >= f then f1 >= f1 -Proof. By property (R2), with f1=f2 - -Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (lhs -f-> t), where - lhs is a type variable or an exactly-saturated type family application - (that is, lhs is a CanEqLHS) - t is a type - f is a flavour -such that - (WF1) if (lhs1 -f1-> t1) in S - (lhs2 -f2-> t2) in S - then (f1 >= f2) implies that lhs1 does not appear within lhs2 - (WF2) if (lhs -f-> t) is in S, then t /= lhs - -Definition [Applying a generalised substitution] -If S is a generalised substitution - S(f,t0) = t, if (t0 -fs-> t) in S, and fs >= f - = apply S to components of t0, otherwise -See also Note [Flavours with roles]. - -Theorem: S(f,t0) is well defined as a function. -Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S, - and f1 >= f and f2 >= f - Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) - -Notation: repeated application. - S^0(f,t) = t - S^(n+1)(f,t) = S(f, S^n(t)) - -Definition: terminating generalised substitution -A generalised substitution S is *terminating* iff - - (IG1) there is an n such that - for every f,t, S^n(f,t) = S^(n+1)(f,t) - -By (IG1) we define S*(f,t) to be the result of exahaustively -applying S(f,_) to t. - ------------------------------------------------------------------------------ -Our main invariant: - the CEqCans in inert_eqs should be a terminating generalised substitution ------------------------------------------------------------------------------ - -Note that termination is not the same as idempotence. To apply S to a -type, you may have to apply it recursively. But termination does -guarantee that this recursive use will terminate. - -Note [Why R2?] -~~~~~~~~~~~~~~ -R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >= -f1. If we do not have R2, we will easily fall into a loop. - -To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our -inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And -yet, we have a hard time noticing an occurs-check problem when building S, as -the two equalities cannot rewrite one another. - -R2 actually restricts our ability to accept user-written programs. See -Note [Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example. - -Note [Rewritable] -~~~~~~~~~~~~~~~~~ -This Note defines what it means for a type variable or type family application -(that is, a CanEqLHS) to be rewritable in a type. This definition is used -by the anyRewritableXXX family of functions and is meant to model the actual -behaviour in GHC.Tc.Solver.Rewrite. - -Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the -lhs tree appears as a subtree within t without traversing any of the following -components of t: - * coercions (whether they appear in casts CastTy or as arguments CoercionTy) - * kinds of variable occurrences -The check for rewritability *does* look in kinds of the bound variable of a -ForAllTy. - -Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised -substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f -for all f. - -The reason for this definition is that the rewriter does not rewrite in coercions -or variables' kinds. In turn, the rewriter does not need to rewrite there because -those places are never used for controlling the behaviour of the solver: these -places are not used in matching instances or in decomposing equalities. - -There is one exception to the claim that non-rewritable parts of the tree do -not affect the solver: we sometimes do an occurs-check to decide e.g. how to -orient an equality. (See the comments on -GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a -variable in a kind or coercion just might influence the solver. Here is an -example: - - type family Const x y where - Const x y = x - - AxConst :: forall x y. Const x y ~# x - - alpha :: Const Type Nat - [W] alpha ~ Int |> (sym (AxConst Type alpha) ;; - AxConst Type alpha ;; - sym (AxConst Type Nat)) - -The cast is clearly ludicrous (it ties together a cast and its symmetric version), -but we can't quite rule it out. (See (EQ1) from -Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need -the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha -from unifying with the RHS. I (Richard E) don't have an example of where this -problem can arise from a Haskell program, but we don't have an air-tight argument -for why the definition of *rewritable* given here is correct. - -Taking roles into account: we must consider a rewrite at a given role. That is, -a rewrite arises from some equality, and that equality has a role associated -with it. As we traverse a type, we track what role we are allowed to rewrite with. - -For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in -Maybe b but not in F b, where F is a type function. This role-aware logic is -present in both the anyRewritableXXX functions and in the rewriter. -See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Main Theorem [Stability under extension] - Suppose we have a "work item" - lhs -fw-> t - and a terminating generalised substitution S, - THEN the extended substitution T = S+(lhs -fw-> t) - is a terminating generalised substitution - PROVIDED - (T1) S(fw,lhs) = lhs -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) lhs not in t -- No occurs check in the work item - -- If lhs is a type family application, we require only that - -- lhs is not *rewritable* in t. See Note [Rewritable] and - -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. - - AND, for every (lhs1 -fs-> s) in S: - (K0) not (fw >= fs) - Reason: suppose we kick out (lhs1 -fs-> s), - and add (lhs -fw-> t) to the inert set. - The latter can't rewrite the former, - so the kick-out achieved nothing - - -- From here, we can assume fw >= fs - OR (K4) lhs1 is a tyvar AND fs >= fw - - OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable]. - Reason: if fw >= fs, WF1 says we can't have both - lhs0 -fw-> t and F lhs0 -fs-> s - - AND (K2): guarantees termination of the new substitution - { (K2a) not (fs >= fs) - OR (K2b) lhs not in s } - - AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= lhs - (K3b) If the role of fs is representational: - s is not of form (lhs t1 .. tn) } } - - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable - -The idea is that -* T1 and T2 are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by an occurs-check on the work item. - This is done during canonicalisation, in canEqOK and checkTypeEq; invariant - (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. See also (K2a) below. - -* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing - Proof: using Definition [Can-rewrite relation], fw can't rewrite anything - and so K0 holds. Intuitively, since fw can't rewrite anything (Lemma (L0)), - adding it cannot cause any loops - This is a common case, because Wanteds cannot rewrite Wanteds. - It's used to avoid even looking for constraint to kick out. - -* Lemma (L1): The conditions of the Main Theorem imply that there is no - (lhs -fs-> t) in S, s.t. (fs >= fw). - Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,lhs)=lhs. But since fs>=fw, S(fw,lhs) = t, hence t=lhs. But now we - have (lhs -fs-> lhs) in S, which contradicts (WF2). - -* The extended substitution satisfies (WF1) and (WF2) - - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - - (T3) guarantees (WF2). - -* (K2) and (K4) are about termination. Intuitively, any infinite chain S^0(f,t), - S^1(f,t), S^2(f,t).... must pass through the new work item infinitely - often, since the substitution without the work item is terminating; and must - pass through at least one of the triples in S infinitely often. - - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f) - (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t). - It is always safe to extend S with such a triple. - - (NB: we could strengten K1) in this way too, but see K3. - - - (K2b): if lhs not in s, we have no further opportunity to apply the - work item - - - (K4): See Note [K4] - -* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then - if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s. - Proof. K4 holds; thus, we keep. - -Key lemma to make it watertight. - Under the conditions of the Main Theorem, - forall f st fw >= f, a is not in S^k(f,t), for any k - -Also, consider roles more carefully. See Note [Flavours with roles] - -Note [K4] -~~~~~~~~~ -K4 is a "keep" condition of Note [Extending the inert equalities]. -Here is the scenario: - -* We are considering adding (lhs -fw-> t) to the inert set S. -* S already has (lhs1 -fs-> s). -* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t. - See Note [Rewritable]. These are (T1), (T2), and (T3). -* We further know fw >= fs. (If not, then we short-circuit via (K0).) - -K4 says that we may keep lhs1 -fs-> s in S if: - lhs1 is a tyvar AND fs >= fw - -Why K4 guarantees termination: - * If fs >= fw, we know a is not rewritable in t, because of (T2). - * We further know lhs /= a, because of (T1). - * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions - for a use of a -fs-> s (precisely because t does not mention a), and hence, - the extended substitution (with lhs -fw-> t in it) is a terminating - generalised substitution. - -Recall that the termination generalised substitution includes only mappings that -pass an occurs check. This is (T3). At one point, we worried that the -argument here would fail if s mentioned a, but (T3) rules out this possibility. -Put another way: the terminating generalised substitution considers only the inert_eqs, -not other parts of the inert set (such as the irreds). - -Can we liberalise K4? No. - -Why we cannot drop the (fs >= fw) condition: - * Suppose not (fs >= fw). It might be the case that t mentions a, and this - can cause a loop. Example: - - Work: [G] b ~ a - Inert: [D] a ~ b - - (where G >= G, G >= D, and D >= D) - If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int. - - * Note that the above example is different if the inert is a Given G, because - (T1) won't hold. - -Why we cannot drop the tyvar condition: - * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2). - * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s? - Yes! This can happen if t appears within tys. - - Here is an example: - - Work: [G] a ~ Int - Inert: [G] F Int ~ F a - - Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand - side. The key reason why K2b works in the tyvar case is that tyvars are atomic: - if the right-hand side of an equality does not mention a variable a, then it - cannot allow an equality with an LHS of a to fire. This is not the case for - type family applications. - -Bottom line: K4 can keep only inerts with tyvars on the left. Put differently, -K4 will never prevent an inert with a type family on the left from being kicked -out. - -Consequence: We never kick out a Given/Nominal equality with a tyvar on the left. -This is Lemma (L3) of Note [Extending the inert equalities]. It is good because -it means we can effectively model the mutable filling of metavariables with -Given/Nominal equalities. That is: it should be the case that we could rewrite -our solver never to fill in a metavariable; instead, it would "solve" a wanted -like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting. -We would want the solver to behave the same whether it uses metavariables or -Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out, -just like we never unfill a metavariable. Nice. - -Getting this wrong (that is, allowing K4 to apply to situations with the type -family on the left) led to #19042. (At that point, K4 was known as K2b.) - -Originally, this condition was part of K2, but #17672 suggests it should be -a top-level K condition. - -Note [K3: completeness of solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(K3) is not necessary for the extended substitution -to be terminating. In fact K1 could be made stronger by saying - ... then (not (fw >= fs) or not (fs >= fs)) -But it's not enough for S to be terminating; we also want completeness. -That is, we want to be able to solve all soluble wanted equalities. -Suppose we have - - work-item b -G-> a - inert-item a -W-> b - -Assuming (G >= W) but not (W >= W), this fulfills all the conditions, -so we could extend the inerts, thus: - - inert-items b -G-> a - a -W-> b - -But if we kicked-out the inert item, we'd get - - work-item a -W-> b - inert-item b -G-> a - -Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. -So we add one more clause to the kick-out criteria - -Another way to understand (K3) is that we treat an inert item - a -f-> b -in the same way as - b -f-> a -So if we kick out one, we should kick out the other. The orientation -is somewhat accidental. - -When considering roles, we also need the second clause (K3b). Consider - - work-item c -G/N-> a - inert-item a -W/R-> b c - -The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. -But we don't kick out the inert item because not (W/R >= W/R). So we just -add the work item. But then, consider if we hit the following: - - work-item b -G/N-> Id - inert-items a -W/R-> b c - c -G/N-> a -where - newtype Id x = Id x - -For similar reasons, if we only had (K3a), we wouldn't kick the -representational inert out. And then, we'd miss solving the inert, which -now reduced to reflexivity. - -The solution here is to kick out representational inerts whenever the -lhs of a work item is "exposed", where exposed means being at the -head of the top-level application chain (lhs t1 .. tn). See -is_can_eq_lhs_head. This is encoded in (K3b). - -Beware: if we make this test succeed too often, we kick out too much, -and the solver might loop. Consider (#14363) - work item: [G] a ~R f b - inert item: [G] b ~R f a -In GHC 8.2 the completeness tests more aggressive, and kicked out -the inert item; but no rewriting happened and there was an infinite -loop. All we need is to have the tyvar at the head. - -Note [Flavours with roles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The system described in Note [inert_eqs: the inert equalities] -discusses an abstract -set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Derived, Given} and the equality relation (often called -role), taken from {NomEq, ReprEq}. -When substituting w.r.t. the inert set, -as described in Note [inert_eqs: the inert equalities], -we must be careful to respect all components of a flavour. -For example, if we have - - inert set: a -G/R-> Int - b -G/R-> Bool - - type role T nominal representational - -and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT -T Int Bool. The reason is that T's first parameter has a nominal role, and -thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of -substitution means that the proof in Note [inert_eqs: the inert equalities] may -need to be revisited, but we don't think that the end conclusion is wrong. --} - -data InertCans -- See Note [Detailed InertCans Invariants] for more - = IC { inert_eqs :: InertEqs - -- See Note [inert_eqs: the inert equalities] - -- All CEqCans with a TyVarLHS; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: FunEqMap EqualCtList - -- All CEqCans with a TyFamLHS; index is the whole family head type. - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include all flavours, [G], [W], [WD], [D] - - , inert_dicts :: DictMap Ct - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_insts :: [QCInst] - - , inert_safehask :: DictMap Ct - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in GHC.Tc.Solver - - , inert_irreds :: Cts - -- Irreducible predicates that cannot be made canonical, - -- and which don't interact with others (e.g. (c a)) - -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_given_eq_lvl :: TcLevel - -- The TcLevel of the innermost implication that has a Given - -- equality of the sort that make a unification variable untouchable - -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). - -- See Note [Tracking Given equalities] - - , inert_given_eqs :: Bool - -- True <=> The inert Givens *at this level* (tcl_tclvl) - -- could includes at least one equality /other than/ a - -- let-bound skolem equality. - -- Reason: report these givens when reporting a failed equality - -- See Note [Tracking Given equalities] - } - -type InertEqs = DTyVarEnv EqualCtList - -instance Outputable InertCans where - ppr (IC { inert_eqs = eqs - , inert_funeqs = funeqs, inert_dicts = dicts - , inert_safehask = safehask, inert_irreds = irreds - , inert_given_eq_lvl = ge_lvl - , inert_given_eqs = given_eqs - , inert_insts = insts }) - - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities:" - <+> pprCts (foldDVarEnv folder emptyCts eqs) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprCts (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) - , ppUnless (isEmptyCts irreds) $ - text "Irreds =" <+> pprCts irreds - , ppUnless (null insts) $ - text "Given instances =" <+> vcat (map ppr insts) - , text "Innermost given equalities =" <+> ppr ge_lvl - , text "Given eqs at this level =" <+> ppr given_eqs - ] - where - folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct) - where - add_eq old_eqs _ = addToEqualCtList ct old_eqs - -addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct - -> FunEqMap EqualCtList -addCanFunEq old_eqs fun_tc fun_args ct - = alterTcApp old_eqs fun_tc fun_args upd - where - upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list - upd Nothing = Just $ unitEqualCtList ct - -foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> [Ct] -findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $ - lookupDVarEnv (inert_eqs icans) tv) - -delEq :: InertCans -> CanEqLHS -> TcType -> InertCans -delEq ic lhs rhs = case lhs of - TyVarLHS tv - -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv } - TyFamLHS tf args - -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd } - where - isThisOne :: Ct -> Bool - isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1 - isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other) - - upd :: Maybe EqualCtList -> Maybe EqualCtList - upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list - upd Nothing = Nothing - -findEq :: InertCans -> CanEqLHS -> [Ct] -findEq icans (TyVarLHS tv) = findTyEqs icans tv -findEq icans (TyFamLHS fun_tc fun_args) - = maybe [] id (fmap @Maybe equalCtListToList $ - findFunEq (inert_funeqs icans) fun_tc fun_args) - -{- ********************************************************************* -* * - Adding to and removing from the inert set -* * -* * -********************************************************************* -} - -addInertItem :: TcLevel -> InertCans -> Ct -> InertCans -addInertItem tc_lvl - ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs }) - item@(CEqCan { cc_lhs = lhs }) - = updateGivenEqs tc_lvl item $ - case lhs of - TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item } - TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv item } - -addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {}) - = updateGivenEqs tc_lvl item $ -- An Irred might turn out to be an - -- equality, so we play safe - ics { inert_irreds = irreds `snocBag` item } - -addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item } - -addInertItem _ _ item - = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical because they only land in inert_irreds - -updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans --- Set the inert_given_eq_level to the current level (tclvl) --- if the constraint is a given equality that should prevent --- filling in an outer unification variable. --- See Note [Tracking Given equalities] -updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl }) - | not (isGivenCt ct) = inerts - | not_equality ct = inerts -- See Note [Let-bound skolems] - | otherwise = inerts { inert_given_eq_lvl = ge_lvl' - , inert_given_eqs = True } - where - ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct) - -- Includes things like (c a), which *might* be an equality - = tclvl - | otherwise - = ge_lvl - - not_equality :: Ct -> Bool - -- True <=> definitely not an equality of any kind - -- except for a let-bound skolem, which doesn't count - -- See Note [Let-bound skolems] - -- NB: no need to spot the boxed CDictCan (a ~ b) because its - -- superclass (a ~# b) will be a CEqCan - not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv) - not_equality (CDictCan {}) = True - not_equality _ = False - -kickOutRewritableLHS :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> CanEqLHS -- The new equality is lhs ~ ty - -> InertCans - -> (WorkList, InertCans) --- See Note [kickOutRewritable] -kickOutRewritableLHS new_fr new_lhs - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insts = old_insts }) - | not (new_fr `eqMayRewriteFR` new_fr) - = (emptyWorkList, ics) - -- If new_fr can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything. - -- (This is a common case: wanteds can't rewrite wanteds) - -- Lemma (L2) in Note [Extending the inert equalities] - - | otherwise - = (kicked_out, inert_cans_in) - where - -- inert_safehask stays unchanged; is that right? - inert_cans_in = ics { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insts = insts_in } - - kicked_out :: WorkList - -- NB: use extendWorkList to ensure that kicked-out equalities get priority - -- See Note [Prioritise equalities] (Kick-out). - -- The irreds may include non-canonical (hetero-kinded) equality - -- constraints, which perhaps may have become soluble after new_lhs - -- is substituted; ditto the dictionaries, which may include (a~b) - -- or (a~~b) constraints. - kicked_out = foldr extendWorkListCt - (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out }) - ((dicts_out `andCts` irs_out) - `extendCtsList` insts_out) - - (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs) - ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = foldFunEqs (kick_out_eqs extend_fun_eqs) - funeqmap ([], emptyFunEqs) - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds - -- Kick out even insolubles: See Note [Rewrite insolubles] - -- Of course we must kick out irreducibles like (c a), in case - -- we can rewrite 'c' to something more useful - - -- Kick-out for inert instances - -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical - insts_out :: [Ct] - insts_in :: [QCInst] - (insts_out, insts_in) - | fr_may_rewrite (Given, NomEq) -- All the insts are Givens - = partitionWith kick_out_qci old_insts - | otherwise - = ([], old_insts) - kick_out_qci qci - | let ev = qci_ev qci - , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) - = Left (mkNonCanonical ev) - | otherwise - = Right qci - - (_, new_role) = new_fr - - fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool - fr_tv_can_rewrite_ty new_tv role ty - = anyRewritableTyVar True role can_rewrite ty - -- True: ignore casts and coercions - where - can_rewrite :: EqRel -> TyVar -> Bool - can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv - - fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool - fr_tf_can_rewrite_ty new_tf new_tf_args role ty - = anyRewritableTyFamApp role can_rewrite ty - where - can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool - can_rewrite old_role old_tf old_tf_args - = new_role `eqCanRewrite` old_role && - tcEqTyConApps new_tf new_tf_args old_tf old_tf_args - -- it's possible for old_tf_args to have too many. This is fine; - -- we'll only check what we need to. - - {-# INLINE fr_can_rewrite_ty #-} -- perform the check here only once - fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty = case new_lhs of - TyVarLHS new_tv -> fr_tv_can_rewrite_ty new_tv - TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs - -- Can the new item rewrite the inert item? - - {-# INLINE kick_out_ct #-} -- perform case on new_lhs here only once - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct = case new_lhs of - TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in - fr_may_rewrite fs - && fr_tv_can_rewrite_ty new_tv role (ctPred ct) - TyFamLHS new_tf new_tf_args - -> \ct -> let fs@(_, role) = ctFlavourRole ct in - fr_may_rewrite fs - && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct) - - extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs - extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts - extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other) - - extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList - -> FunEqMap EqualCtList - extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts - = insertTcApp eqs fam_tc fam_args cts - extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other) - - kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container) - -> EqualCtList -> ([Ct], container) - -> ([Ct], container) - kick_out_eqs extend eqs (acc_out, acc_in) - = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of - Nothing -> acc_in - Just eqs_in_ecl@(EqualCtList (eq1 :| _)) - -> extend acc_in (cc_lhs eq1) eqs_in_ecl) - where - (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs) - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty - , cc_ev = ev, cc_eq_rel = eq_rel }) - | not (fr_may_rewrite fs) - = False -- (K0) Keep it in the inert set if the new thing can't rewrite it - - -- Below here (fr_may_rewrite fs) is True - - | TyVarLHS _ <- lhs - , fs `eqMayRewriteFR` new_fr - = False -- (K4) Keep it in the inert set if the LHS is a tyvar and - -- it can rewrite the work item. See Note [K4] - - | fr_can_rewrite_ty eq_rel (canEqLHSType lhs) - = True -- (K1) - -- The above check redundantly checks the role & flavour, - -- but it's very convenient - - | kick_out_for_inertness = True -- (K2) - | kick_out_for_completeness = True -- (K3) - | otherwise = False - - where - fs = (ctEvFlavour ev, eq_rel) - kick_out_for_inertness - = (fs `eqMayRewriteFR` fs) -- (K2a) - && fr_can_rewrite_ty eq_rel rhs_ty -- (K2b) - - kick_out_for_completeness -- (K3) and Note [K3: completeness of solving] - = case eq_rel of - NomEq -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a) - ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty -- (K3b) - - kick_out_eq ct = pprPanic "keep_eq" (ppr ct) - - is_can_eq_lhs_head (TyVarLHS tv) = go - where - go (Rep.TyVarTy tv') = tv == tv' - go (Rep.AppTy fun _) = go fun - go (Rep.CastTy ty _) = go ty - go (Rep.TyConApp {}) = False - go (Rep.LitTy {}) = False - go (Rep.ForAllTy {}) = False - go (Rep.FunTy {}) = False - go (Rep.CoercionTy {}) = False - is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go - where - go (Rep.TyVarTy {}) = False - go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy - go (Rep.CastTy ty _) = go ty - go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args - go (Rep.LitTy {}) = False - go (Rep.ForAllTy {}) = False - go (Rep.FunTy {}) = False - go (Rep.CoercionTy {}) = False - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (lhs ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'lhs' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use anyRewritableCanLHS, which examines the types /and - kinds/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this LHS! - - - A Derived equality can kick out [D] constraints in inert_eqs, - inert_dicts, inert_irreds etc. - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - -NB: we could in principle avoid kick-out: - a) When unifying a meta-tyvar from an outer level, because - then the entire implication will be iterated; see - Note [The Unification Level Flag] in GHC.Tc.Solver.Monad. - - b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType - Note [TcLevel invariants], a Given can't include a meta-tyvar from - its own level, so it falls under (a). Of course, we must still - kick out Givens when adding a new non-unification Given. - -But kicking out more vigorously may lead to earlier unification and fewer -iterations, so we don't take advantage of these possibilities. - -Note [Rewrite insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an insoluble alpha ~ [alpha], which is insoluble -because an occurs check. And then we unify alpha := [Int]. Then we -really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can -be decomposed. Otherwise we end up with a "Can't match [Int] ~ -[[Int]]" which is true, but a bit confusing because the outer type -constructors match. - -Hence: - * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, - simpl_loop), we feed the insolubles in solveSimpleWanteds, - so that they get rewritten (albeit not solved). - - * We kick insolubles out of the inert set, if they can be - rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) - - * We rewrite those insolubles in GHC.Tc.Solver.Canonical. - See Note [Make sure that insolubles are fully rewritten] - in GHC.Tc.Solver.Canonical. --} - -{- ********************************************************************* -* * - Queries -* * -* * -********************************************************************* -} - -mentionsOuterVar :: TcLevel -> CtEvidence -> Bool -mentionsOuterVar tclvl ev - = anyFreeVarsOfType (isOuterTyVar tclvl) $ - ctEvPred ev - -isOuterTyVar :: TcLevel -> TyCoVar -> Bool --- True of a type variable that comes from a --- shallower level than the ambient level (tclvl) -isOuterTyVar tclvl tv - | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $ - tclvl `strictlyDeeperThan` tcTyVarLevel tv - -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from - -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't - -- be a touchable meta tyvar. If this wasn't true, you might worry that, - -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby - -- becomes "outer" even though its level numbers says it isn't. - | otherwise = False -- Coercion variables; doesn't much matter - --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a --- Given might overlap with an instance. See Note [Instance and Given overlap] --- in "GHC.Tc.Solver.Interact" -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans }) - = filterBag matchable_given all_relevant_givens - where - -- just look in class constraints and irreds. matchableGivens does get called - -- for ~R constraints, but we don't need to look through equalities, because - -- canonical equalities are used for rewriting. We'll only get caught by - -- non-canonical -- that is, irreducible -- equalities. - all_relevant_givens :: Cts - all_relevant_givens - | Just (clas, _) <- getClassPredTys_maybe pred_w - = findDictsByClass (inert_dicts inert_cans) clas - `unionBags` inert_irreds inert_cans - | otherwise - = inert_irreds inert_cans - - matchable_given :: Ct -> Bool - matchable_given ct - | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightEqualLater inerts pred_g loc_g pred_w loc_w - - | otherwise - = False - -mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool --- See Note [What might equal later?] --- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact -mightEqualLater (IS { inert_cycle_breakers = cbvs }) - given_pred given_loc wanted_pred wanted_loc - | prohibitedSuperClassSolve given_loc wanted_loc - = False - - | otherwise - = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of - SurelyApart -> False -- types that are surely apart do not equal later - MaybeApart MARInfinite _ -> False -- see Example 7 in the Note. - _ -> True - - where - in_scope = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred] - - -- NB: flatten both at the same time, so that we can share mappings - -- from type family applications to variables, and also to guarantee - -- that the fresh variables are really fresh between the given and - -- the wanted. Flattening both at the same time is needed to get - -- Example 10 from the Note. - ([flattened_given, flattened_wanted], var_mapping) - = flattenTysX in_scope [given_pred, wanted_pred] - - bind_fun :: BindFun - bind_fun tv rhs_ty - | isMetaTyVar tv - , can_unify tv (metaTyVarInfo tv) rhs_ty - -- this checks for CycleBreakerTvs and TyVarTvs; forgetting - -- the latter was #19106. - = BindMe - - -- See Examples 4, 5, and 6 from the Note - | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv - , anyFreeVarsOfTypes mentions_meta_ty_var fam_args - = BindMe - - | otherwise - = Apart - - -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars - -- (as they can be unified) - -- and also for CycleBreakerTvs that mentions meta-tyvars - mentions_meta_ty_var :: TyVar -> Bool - mentions_meta_ty_var tv - | isMetaTyVar tv - = case metaTyVarInfo tv of - -- See Examples 8 and 9 in the Note - CycleBreakerTv - | Just tyfam_app <- lookup tv cbvs - -> anyFreeVarsOfType mentions_meta_ty_var tyfam_app - | otherwise - -> pprPanic "mightEqualLater finds an unbound cbv" (ppr tv $$ ppr cbvs) - _ -> True - | otherwise - = False - - -- like canSolveByUnification, but allows cbv variables to unify - can_unify :: TcTyVar -> MetaInfo -> Type -> Bool - can_unify _lhs_tv TyVarTv rhs_ty -- see Example 3 from the Note - | Just rhs_tv <- tcGetTyVar_maybe rhs_ty - = case tcTyVarDetails rhs_tv of - MetaTv { mtv_info = TyVarTv } -> True - MetaTv {} -> False -- could unify with anything - SkolemTv {} -> True - RuntimeUnk -> True - | otherwise -- not a var on the RHS - = False - can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv - -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance -prohibitedSuperClassSolve from_loc solve_loc - | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size - | otherwise - = False diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -11,12 +11,14 @@ import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..), infinity, IntWithInf, intGtLimit ) +import GHC.Types.Error import GHC.Tc.Solver.Canonical import GHC.Types.Var.Set import GHC.Core.Type as Type import GHC.Core.InstEnv ( DFunInstType ) import GHC.Types.Var +import GHC.Tc.Errors.Types import GHC.Tc.Utils.TcType import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) @@ -120,7 +122,8 @@ go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) go n limit wc | n `intGtLimit` limit - = failTcS (hang (text "solveSimpleWanteds: too many iterations" + = failTcS $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (text "solveSimpleWanteds: too many iterations" <+> parens (text "limit =" <+> ppr limit)) 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" , text "Simples =" <+> ppr simples @@ -664,8 +667,8 @@ -- mean that (ty1 ~ ty2) interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_status = status }) - | InsolubleCIS <- status +interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) + | isInsolubleReason reason -- For insolubles, don't allow the constraint to be dropped -- which can happen with solveOneFromTheOther, so that -- we get distinct error messages with -fdefer-type-errors @@ -1584,15 +1587,15 @@ -> TcType -- RHS -> TcS (StopOrContinue Ct) tryToSolveByUnification work_item ev tv rhs - = do { can_unify <- unifyTest ev tv rhs + = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs - , ppr can_unify ]) + , ppr is_touchable ]) - ; case can_unify of - NoUnify -> continueWith work_item + ; case is_touchable of + Untouchable -> continueWith work_item -- For the latter two cases see Note [Solve by unification] - UnifySameLevel -> solveByUnification ev tv rhs - UnifyOuterLevel free_metas tv_lvl + TouchableSameLevel -> solveByUnification ev tv rhs + TouchableOuterLevel free_metas tv_lvl -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas ; setUnificationFlag tv_lvl ; solveByUnification ev tv rhs } } @@ -1664,10 +1667,10 @@ alpha[n] ~ ty by unification, there are two cases to consider -* UnifySameLevel: if the ambient level is 'n', then +* TouchableSameLevel: if the ambient level is 'n', then we can simply update alpha := ty, and do nothing else -* UnifyOuterLevel free_metas n: if the ambient level is greater than +* TouchableOuterLevel free_metas n: if the ambient level is greater than 'n' (the level of alpha), in addition to setting alpha := ty we must do two other things: @@ -1681,7 +1684,7 @@ 2. Set the Unification Level Flag to record that a level-n unification has taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad -NB: UnifySameLevel is just an optimisation for UnifyOuterLevel. Promotion +NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion would be a no-op, and setting the unification flag unnecessarily would just make the solver iterate more often. (We don't need to iterate when unifying at the ambient level because of the kick-out mechanism.) diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -2,8 +2,10 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -42,7 +44,7 @@ newWantedNC, newWantedEvVarNC, newDerivedNC, newBoundEvVarId, - unifyTyVar, reportUnifications, + unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..), setEvBind, setWantedEq, setWantedEvTerm, setEvBindIfWanted, newEvVar, newGivenEvVar, newGivenEvVars, @@ -113,7 +115,7 @@ -- if the whole instance matcher simply belongs -- here - breakTyVarCycle, rewriterView + breakTyVarCycle_maybe, rewriterView ) where import GHC.Prelude @@ -144,6 +146,7 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Tc.Errors ( solverDepthErrorTcS ) +import GHC.Tc.Errors.Types import GHC.Types.Name import GHC.Types.TyThing @@ -161,6 +164,7 @@ import GHC.Tc.Types import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Unify import GHC.Core.Predicate import GHC.Types.Unique.Set @@ -169,7 +173,7 @@ import GHC.Utils.Monad import Data.IORef import GHC.Exts (oneShot) -import Data.List ( mapAccumL ) +import Data.List ( mapAccumL, partition ) import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Arrow ( first ) @@ -696,28 +700,32 @@ holes_of_co = coercionHolesOfCo filled_co kick_out :: InertCans -> (WorkList, InertCans) - kick_out ics@(IC { inert_irreds = irreds }) - = let (to_kick, to_keep) = partitionBagWith kick_ct irreds + kick_out ics@(IC { inert_blocked = blocked }) + = let (to_kick, to_keep) = partitionBagWith kick_ct blocked kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList - ics' = ics { inert_irreds = to_keep } + ics' = ics { inert_blocked = to_keep } in (kicked_out, ics') kick_ct :: Ct -> Either Ct Ct -- Left: kick out; Right: keep. But even if we keep, we may need -- to update the set of blocking holes - kick_ct ct@(CIrredCan { cc_status = BlockedCIS holes }) + kick_ct ct@(CIrredCan { cc_reason = HoleBlockerReason holes }) | hole `elementOfUniqSet` holes = let new_holes = holes `delOneFromUniqSet` hole `unionUniqSets` holes_of_co - updated_ct = ct { cc_status = BlockedCIS new_holes } + updated_ct = ct { cc_reason = HoleBlockerReason new_holes } in if isEmptyUniqSet new_holes then Left updated_ct else Right updated_ct - kick_ct other = Right other + | otherwise + = Right ct + + kick_ct other = pprPanic "kickOutAfterFillingCoercionHole" (ppr other) + -------------- addInertSafehask :: InertCans -> Ct -> InertCans addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) @@ -887,17 +895,21 @@ -- (because they come from the inert set) -- the unsolved implics may not be getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds + , inert_blocked = blocked + , inert_dicts = idicts } <- getInertCans ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts unsolved_irreds = Bag.filterBag is_unsolved irreds + unsolved_blocked = blocked -- all blocked equalities are W/D unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unsolved_irreds `unionBags` unsolved_dicts + unsolved_others = unionManyBags [ unsolved_irreds + , unsolved_dicts + , unsolved_blocked ] ; implics <- getWorkListImplics @@ -1009,7 +1021,7 @@ where cbv = F a The cbv is a cycle-breaker var which stands for F a. See - Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical. + Note [Type variable cycles] in GHC.Tc.Solver.Canonical. This is just like case 6, and we say "no". Saying "no" here is essential in getting the parser to type-check, with its use of DisambECP. @@ -1230,11 +1242,11 @@ -- There's no static check; it's up to the user wrapWarnTcS = wrapTcS -failTcS, panicTcS :: SDoc -> TcS a -warnTcS :: WarningFlag -> SDoc -> TcS () -addErrTcS :: SDoc -> TcS () +panicTcS :: SDoc -> TcS a +failTcS :: TcRnMessage -> TcS a +warnTcS, addErrTcS :: TcRnMessage -> TcS () failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addDiagnostic (WarningWithFlag flag) +warnTcS msg = wrapTcS (TcM.addDiagnostic msg) addErrTcS = wrapTcS . TcM.addErr panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc @@ -1278,9 +1290,9 @@ csTraceTcM :: TcM SDoc -> TcM () -- Constraint-solver tracing, -ddump-cs-trace csTraceTcM mk_doc - = do { dflags <- getDynFlags - ; when ( dopt Opt_D_dump_cs_trace dflags - || dopt Opt_D_dump_tc_trace dflags ) + = do { logger <- getLogger + ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace + || logHasDumpFlag logger Opt_D_dump_tc_trace) ( do { msg <- mk_doc ; TcM.dumpTcRn False Opt_D_dump_cs_trace @@ -1327,7 +1339,7 @@ runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards? -- Don't if you want to reuse the InertSet. - -- See also Note [Type variable cycles in Givens] + -- See also Note [Type variable cycles] -- in GHC.Tc.Solver.Canonical -> EvBindsVar -> TcS a @@ -1624,6 +1636,82 @@ ; TcM.updTcRef (tcs_unified env) (+ n_unifs) ; return (n_unifs, res) } +data TouchabilityTestResult + -- See Note [Solve by unification] in GHC.Tc.Solver.Interact + -- which points out that having TouchableSameLevel is just an optimisation; + -- we could manage with TouchableOuterLevel alone (suitably renamed) + = TouchableSameLevel + | TouchableOuterLevel [TcTyVar] -- Promote these + TcLevel -- ..to this level + | Untouchable + +instance Outputable TouchabilityTestResult where + ppr TouchableSameLevel = text "TouchableSameLevel" + ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs) + ppr Untouchable = text "Untouchable" + +touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult +-- This is the key test for untouchability: +-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify +-- and Note [Solve by unification] in GHC.Tc.Solver.Interact +touchabilityTest flav tv1 rhs + | flav /= Given -- See Note [Do not unify Givens] + , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1 + , canSolveByUnification info rhs + = do { ambient_lvl <- getTcLevel + ; given_eq_lvl <- getInnermostGivenEqLevel + + ; if | tv_lvl `sameDepthAs` ambient_lvl + -> return TouchableSameLevel + + | tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities + , all (does_not_escape tv_lvl) free_skols -- No skolem escapes + -> return (TouchableOuterLevel free_metas tv_lvl) + + | otherwise + -> return Untouchable } + | otherwise + = return Untouchable + where + (free_metas, free_skols) = partition isPromotableMetaTyVar $ + nonDetEltsUniqSet $ + tyCoVarsOfType rhs + + does_not_escape tv_lvl fv + | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv + | otherwise = True + -- Coercion variables are not an escape risk + -- If an implication binds a coercion variable, it'll have equalities, + -- so the "intervening given equalities" test above will catch it + -- Coercion holes get filled with coercions, so again no problem. + +{- Note [Do not unify Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GADT match + data T a where + T1 :: T Int + ... + + f x = case x of + T1 -> True + ... + +So we get f :: T alpha[1] -> beta[1] + x :: T alpha[1] +and from the T1 branch we get the implication + forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool + +Now, clearly we don't want to unify alpha:=Int! Yet at the moment we +process [G] alpha[1] ~ Int, we don't have any given-equalities in the +inert set, and hence there are no given equalities to make alpha untouchable. + +NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that +never happens: invariant (GivenInv) in Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. + +Simple solution: never unify in Givens! +-} + getDefaultInfo :: TcS ([Type], (Bool, Bool)) getDefaultInfo = wrapTcS TcM.tcGetDefaultTys @@ -2130,51 +2218,123 @@ ************************************************************************ -} --- | Replace all type family applications in the RHS with fresh variables, --- emitting givens that relate the type family application to the variable. --- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical. -breakTyVarCycle :: CtLoc - -> TcType -- the RHS - -> TcS TcType -- new RHS that doesn't have any type families --- This could be considerably more efficient. See Detail (5) of Note. -breakTyVarCycle loc = go +-- | Conditionally replace all type family applications in the RHS with fresh +-- variables, emitting givens that relate the type family application to the +-- variable. See Note [Type variable cycles] in GHC.Tc.Solver.Canonical. +-- This only works under conditions as described in the Note; otherwise, returns +-- Nothing. +breakTyVarCycle_maybe :: CtEvidence + -> CheckTyEqResult -- result of checkTypeEq + -> CanEqLHS + -> TcType -- RHS + -> TcS (Maybe (TcTyVar, CoercionN, TcType)) + -- new RHS that doesn't have any type families + -- co :: new type ~N old type + -- TcTyVar is the LHS tv; convenient for the caller +breakTyVarCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _ + -- see Detail (7) of Note + = return Nothing + +breakTyVarCycle_maybe ev cte_result (TyVarLHS lhs_tv) rhs + | NomEq <- eq_rel + + , cte_result `cterHasOnlyProblem` cteSolubleOccurs + -- only do this if the only problem is a soluble occurs-check + -- See Detail (8) of the Note. + + = do { should_break <- final_check + ; if should_break then do { (co, new_rhs) <- go rhs + ; return (Just (lhs_tv, co, new_rhs)) } + else return Nothing } where + flavour = ctEvFlavour ev + eq_rel = ctEvEqRel ev + + final_check + | Given <- flavour + = return True + | ctFlavourContainsDerived flavour + = do { result <- touchabilityTest Derived lhs_tv rhs + ; return $ case result of + Untouchable -> False + _ -> True } + | otherwise + = return False + + -- This could be considerably more efficient. See Detail (5) of Note. + go :: TcType -> TcS (CoercionN, TcType) go ty | Just ty' <- rewriterView ty = go ty' go (Rep.TyConApp tc tys) - | isTypeFamilyTyCon tc + | isTypeFamilyTyCon tc -- worried about whether this type family is not actually + -- causing trouble? See Detail (5) of Note. = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys fun_app = mkTyConApp tc fun_args fun_app_kind = tcTypeKind fun_app - ; new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind) + ; (co, new_ty) <- emit_work fun_app_kind fun_app + ; (extra_args_cos, extra_args') <- mapAndUnzipM go extra_args + ; return (mkAppCos co extra_args_cos, mkAppTys new_ty extra_args') } + -- Worried that this substitution will change kinds? + -- See Detail (3) of Note + + | otherwise + = do { (cos, tys) <- mapAndUnzipM go tys + ; return (mkTyConAppCo Nominal tc cos, mkTyConApp tc tys) } + + go (Rep.AppTy ty1 ty2) + = do { (co1, ty1') <- go ty1 + ; (co2, ty2') <- go ty2 + ; return (mkAppCo co1 co2, mkAppTy ty1' ty2') } + go (Rep.FunTy vis w arg res) + = do { (co_w, w') <- go w + ; (co_arg, arg') <- go arg + ; (co_res, res') <- go res + ; return (mkFunCo Nominal co_w co_arg co_res, mkFunTy vis w' arg' res') } + go (Rep.CastTy ty cast_co) + = do { (co, ty') <- go ty + -- co :: ty' ~N ty + -- return_co :: (ty' |> cast_co) ~ (ty |> cast_co) + ; return (castCoercionKind1 co Nominal ty' ty cast_co, mkCastTy ty' cast_co) } + + go ty@(Rep.TyVarTy {}) = skip ty + go ty@(Rep.LitTy {}) = skip ty + go ty@(Rep.ForAllTy {}) = skip ty -- See Detail (1) of Note + go ty@(Rep.CoercionTy {}) = skip ty -- See Detail (2) of Note + + skip ty = return (mkNomReflCo ty, ty) + + emit_work :: TcKind -- of the function application + -> TcType -- original function application + -> TcS (CoercionN, TcType) -- rewritten type (the fresh tyvar) + emit_work fun_app_kind fun_app = case flavour of + Given -> + do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind) ; let new_ty = mkTyVarTy new_tv given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind fun_app new_ty given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note - ; new_given <- newGivenEvVar loc (given_pred, given_term) - ; traceTcS "breakTyVarCycle replacing type family" (ppr new_given) + ; new_given <- newGivenEvVar new_loc (given_pred, given_term) + ; traceTcS "breakTyVarCycle replacing type family in Given" (ppr new_given) ; emitWorkNC [new_given] ; updInertTcS $ \is -> is { inert_cycle_breakers = (new_tv, fun_app) : inert_cycle_breakers is } - ; extra_args' <- mapM go extra_args - ; return (mkAppTys new_ty extra_args') } - -- Worried that this substitution will change kinds? - -- See Detail (3) of Note + ; return (mkNomReflCo new_ty, new_ty) } + -- Why reflexive? See Detail (4) of the Note - | otherwise - = mkTyConApp tc <$> mapM go tys + _derived_or_wd -> + do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind) + ; let new_ty = mkTyVarTy new_tv + ; co <- emitNewWantedEq new_loc Nominal new_ty fun_app + ; return (co, new_ty) } - go (Rep.AppTy ty1 ty2) = mkAppTy <$> go ty1 <*> go ty2 - go (Rep.FunTy vis w arg res) = mkFunTy vis <$> go w <*> go arg <*> go res - go (Rep.CastTy ty co) = mkCastTy <$> go ty <*> pure co + -- See Detail (7) of the Note + new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin - go ty@(Rep.TyVarTy {}) = return ty - go ty@(Rep.LitTy {}) = return ty - go ty@(Rep.ForAllTy {}) = return ty -- See Detail (1) of Note - go ty@(Rep.CoercionTy {}) = return ty -- See Detail (2) of Note +-- does not fit scenario from Note +breakTyVarCycle_maybe _ _ _ _ = return Nothing -- | Fill in CycleBreakerTvs with the variables they stand for. --- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical. +-- See Note [Type variable cycles] in GHC.Tc.Solver.Canonical. restoreTyVarCycles :: InertSet -> TcM () restoreTyVarCycles is = forM_ (inert_cycle_breakers is) $ \ (cycle_breaker_tv, orig_ty) -> diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs deleted file mode 100644 --- a/compiler/GHC/Tc/Solver/Types.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Utility types used within the constraint solver -module GHC.Tc.Solver.Types ( - -- Inert CDictCans - DictMap, emptyDictMap, findDictsByClass, addDict, addDictCt, - addDictsByClass, delDict, foldDicts, filterDicts, findDict, - dictsToBag, partitionDicts, - - FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq, - findFunEqsByTyCon, - - TcAppMap, isEmptyTcAppMap, insertTcApp, alterTcApp, filterTcAppMap, - - EqualCtList, pattern EqualCtList, - equalCtListToList, filterEqualCtList, unitEqualCtList, - listToEqualCtList, addToEqualCtList, - ) where - -import GHC.Prelude - -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType - -import GHC.Core.Class -import GHC.Core.Map.Type -import GHC.Core.Predicate -import GHC.Core.TyCon -import GHC.Core.TyCon.Env - -import GHC.Data.Bag -import GHC.Data.Maybe -import GHC.Data.TrieMap -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import Data.Foldable -import Data.List.NonEmpty ( NonEmpty(..), nonEmpty, cons ) -import qualified Data.List.NonEmpty as NE - -{- ********************************************************************* -* * - TcAppMap -* * -************************************************************************ - -Note [Use loose types in inert set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Whenever we are looking up an inert dictionary (CDictCan) or function -equality (CEqCan), we use a TcAppMap, which uses the Unique of the -class/type family tycon and then a trie which maps the arguments. This -trie does *not* need to match the kinds of the arguments; this Note -explains why. - -Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'), -where ty4 and ty4' have different kinds. Let's further assume that both types -ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that -one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth -argument to T is dependent on whichever one changed). Since we are matching -all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed -match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too -- -without ever looking at it. - -Accordingly, we use LooseTypeMap, which skips the kind check when looking -up a type. I (Richard E) believe this is just an optimization, and that -looking at kinds would be harmless. - --} - -type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a) - -- Indexed by tycon then the arg types, using "loose" matching, where - -- we don't require kind equality. This allows, for example, (a |> co) - -- to match (a). - -- See Note [Use loose types in inert set] - -- Used for types and classes; hence UniqDFM - -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here - -isEmptyTcAppMap :: TcAppMap a -> Bool -isEmptyTcAppMap m = isEmptyDTyConEnv m - -emptyTcAppMap :: TcAppMap a -emptyTcAppMap = emptyDTyConEnv - -findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a -findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc - ; lookupTM tys tys_map } - -delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a -delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc - -insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a -insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc - where - alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) - -alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a -alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc - where - alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a) - alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM)) - -filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a -filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m - where - one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a) - one_tycon tm - | isEmptyTM filtered_tm = Nothing - | otherwise = Just filtered_tm - where - filtered_tm = filterTM f tm - -tcAppMapToBag :: TcAppMap a -> Bag a -tcAppMapToBag m = foldTcAppMap consBag m emptyBag - -foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b -foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m - -{- ********************************************************************* -* * - DictMap -* * -********************************************************************* -} - -type DictMap a = TcAppMap a - -emptyDictMap :: DictMap a -emptyDictMap = emptyTcAppMap - -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a -findDict m loc cls tys - | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters] - = Nothing - - | Just {} <- isCallStackPred cls tys - , OccurrenceOf {} <- ctLocOrigin loc - = Nothing -- See Note [Solving CallStack constraints] - - | otherwise - = findTcApp m (classTyCon cls) tys - -findDictsByClass :: DictMap a -> Class -> Bag a -findDictsByClass m cls - | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag - | otherwise = emptyBag - -delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (classTyCon cls) tys - -addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (classTyCon cls) tys item - -addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct --- Like addDict, but combines [W] and [D] to [WD] --- See Note [KeepBoth] in GHC.Tc.Solver.Interact -addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct - where - new_ct_ev = ctEvidence new_ct - - xt_ct :: Maybe Ct -> Maybe Ct - xt_ct (Just old_ct) - | CtWanted { ctev_nosh = WOnly } <- old_ct_ev - , CtDerived {} <- new_ct_ev - = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }}) - | CtDerived {} <- old_ct_ev - , CtWanted { ctev_nosh = WOnly } <- new_ct_ev - = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }}) - where - old_ct_ev = ctEvidence old_ct - - xt_ct _ = Just new_ct - -addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct -addDictsByClass m cls items - = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items) - where - add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm - add ct _ = pprPanic "addDictsByClass" (ppr ct) - -filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = filterTcAppMap f m - -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, add ct noes) - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m - = addDict m cls tys ct - add ct _ = pprPanic "partitionDicts" (ppr ct) - -dictsToBag :: DictMap a -> Bag a -dictsToBag = tcAppMapToBag - -foldDicts :: (a -> b -> b) -> DictMap a -> b -> b -foldDicts = foldTcAppMap - -{- Note [Tuples hiding implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f,g :: (?x::Int, C a) => a -> a - f v = let ?x = 4 in g v - -The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). -We must /not/ solve this from the Given (?x::Int, C a), because of -the intervening binding for (?x::Int). #14218. - -We deal with this by arranging that we always fail when looking up a -tuple constraint that hides an implicit parameter. Not that this applies - * both to the inert_dicts (lookupInertDict) - * and to the solved_dicts (looukpSolvedDict) -An alternative would be not to extend these sets with such tuple -constraints, but it seemed more direct to deal with the lookup. - -Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose f :: HasCallStack => blah. Then - -* Each call to 'f' gives rise to - [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f - with a CtOrigin that says "OccurrenceOf f". - Remember that HasCallStack is just shorthand for - IP "callStack CallStack - See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by - pushing the call-site info on the stack, and changing the CtOrigin - to record that has been done. - Bind: s1 = pushCallStack s2 - [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin - -* Then, and only then, we can solve the constraint from an enclosing - Given. - -So we must be careful /not/ to solve 's1' from the Givens. Again, -we ensure this by arranging that findDict always misses when looking -up souch constraints. --} - -{- ********************************************************************* -* * - FunEqMap -* * -********************************************************************* -} - -type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair - -emptyFunEqs :: TcAppMap a -emptyFunEqs = emptyTcAppMap - -findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEq m tc tys = findTcApp m tc tys - -findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] --- Get inert function equation constraints that have the given tycon --- in their head. Not that the constraints remain in the inert set. --- We use this to check for derived interactions with built-in type-function --- constructors. -findFunEqsByTyCon m tc - | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm [] - | otherwise = [] - -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b -foldFunEqs = foldTcAppMap - -insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a -insertFunEq m tc tys val = insertTcApp m tc tys val - -{- ********************************************************************* -* * - EqualCtList -* * -********************************************************************* -} - -{- Note [EqualCtList invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * All are equalities - * All these equalities have the same LHS - * The list is never empty - * No element of the list can rewrite any other - * Derived before Wanted - -From the fourth invariant it follows that the list is - - A single [G], or - - Zero or one [D] or [WD], followed by any number of [W] - -The Wanteds can't rewrite anything which is why we put them last --} - -newtype EqualCtList = MkEqualCtList (NonEmpty Ct) - deriving newtype Outputable - -- See Note [EqualCtList invariants] - --- | Pattern synonym for easy unwrapping. NB: unidirectional to --- preserve invariants. -pattern EqualCtList :: NonEmpty Ct -> EqualCtList -pattern EqualCtList cts <- MkEqualCtList cts -{-# COMPLETE EqualCtList #-} - -unitEqualCtList :: Ct -> EqualCtList -unitEqualCtList ct = MkEqualCtList (ct :| []) - -addToEqualCtList :: Ct -> EqualCtList -> EqualCtList --- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList, --- but not the others. See Note [EqualCtList invariants] -addToEqualCtList ct (MkEqualCtList old_eqs) - | isWantedCt ct - , eq1 :| eqs <- old_eqs - = MkEqualCtList (eq1 :| ct : eqs) - | otherwise - = MkEqualCtList (ct `cons` old_eqs) - -filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList -filterEqualCtList pred (MkEqualCtList cts) - = fmap MkEqualCtList (nonEmpty $ NE.filter pred cts) - -equalCtListToList :: EqualCtList -> [Ct] -equalCtListToList (MkEqualCtList cts) = toList cts - -listToEqualCtList :: [Ct] -> Maybe EqualCtList --- NB: This does not maintain invariants other than having the EqualCtList be --- non-empty -listToEqualCtList cts = MkEqualCtList <$> nonEmpty cts diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -33,6 +33,7 @@ import GHC.Hs +import GHC.Tc.Errors.Types ( TcRnMessage(..), LevityCheckProvenance(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -69,6 +70,7 @@ import GHC.Core.DataCon import GHC.Core.Unify +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Env @@ -834,7 +836,7 @@ report_dup :: (Name,Name) -> TcM () report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ addErrTc $ + = setSrcSpan (getSrcSpan n2) $ addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Different names for the same type variable:") 2 info where info | nameOccName n1 /= nameOccName n2 @@ -1629,9 +1631,9 @@ -- Kind-check the types of arguments to a GADT data constructor. kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM () kcConGADTArgs new_or_data res_kind con_args = case con_args of - PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys - RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $ - map (hsLinear . cd_fld_type . unLoc) flds + PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys + RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ + map (hsLinear . cd_fld_type . unLoc) flds kcConDecls :: NewOrData -> Kind -- The result kind signature @@ -2533,7 +2535,8 @@ = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (text "More than one default declaration for" + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + text "More than one default declaration for" <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc @@ -2819,7 +2822,8 @@ do { let tvs = binderVars tcbs ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (text "Illegal injectivity annotation" $$ + (TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds @@ -3675,7 +3679,7 @@ -> TcM [(Scaled TcType, HsSrcBang)] tcConGADTArgs exp_kind (PrefixConGADT btys) = mapM (tcConArg exp_kind) btys -tcConGADTArgs exp_kind (RecConGADT fields) +tcConGADTArgs exp_kind (RecConGADT fields _) = tcRecConDeclFields exp_kind fields tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, @@ -4167,7 +4171,7 @@ to add to the context. The problem is that this also grabs data con wrapper Ids. These could be filtered out. But, painfully, getting the wrapper Ids checks the DataConRep, and forcing the DataConRep - can panic if there is a levity-polymorphic argument. This is #18534. + can panic if there is a representation-polymorphic argument. This is #18534. We don't need the wrapper Ids here anyway. So the code just takes what it needs, via child_tycons. -} @@ -4215,7 +4219,7 @@ ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ + ; checkTc hsBoot $ TcRnUnknownMessage $ mkPlainError noHints $ text "You may define an abstract closed type family" $$ text "only in a .hs-boot file" } ; DataFamilyTyCon {} -> return () @@ -4292,10 +4296,10 @@ -- See Note [Checking partial record field] checkPartialRecordField all_cons fld = setSrcSpan loc $ - warnIfFlag Opt_WarnPartialFields - (not is_exhaustive && not (startsWithUnderscore occ_name)) - (sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) + warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) + (TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ + sep [text "Use of partial record field selector" <> colon, + nest 2 $ quotes (ppr occ_name)]) where loc = getSrcSpan (flSelector fld) occ_name = occName fld @@ -4362,16 +4366,16 @@ -- Reason: it's really the argument of an equality constraint ; checkValidMonoType orig_res_ty - -- If we are dealing with a newtype, we allow levity polymorphism - -- regardless of whether or not UnliftedNewtypes is enabled. A - -- later check in checkNewDataCon handles this, producing a - -- better error message than checkForLevPoly would. + -- If we are dealing with a newtype, we allow representation + -- polymorphism regardless of whether or not UnliftedNewtypes + -- is enabled. A later check in checkNewDataCon handles this, + -- producing a better error message than checkForLevPoly would. ; unless (isNewTyCon tc) $ checkNoErrs $ - mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con) + mapM_ (checkForLevPoly LevityCheckInValidDataCon) (map scaledThing $ dataConOrigArgTys con) -- the checkNoErrs is to prevent a panic in isVanillaDataCon -- (called a a few lines down), which can fall over if there is a - -- bang on a levity-polymorphic argument. This is #18534, + -- bang on a representation-polymorphic argument. This is #18534, -- typecheck/should_fail/T18534 -- Extra checks for newtype data constructors. Importantly, these @@ -4396,11 +4400,13 @@ check_bang bang rep_bang n | HsSrcBang _ _ SrcLazy <- bang , not (xopt LangExt.StrictData dflags) - = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData")) + = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (bad_bang n (text "Lazy annotation (~) without StrictData")) | HsSrcBang _ want_unpack strict_mark <- bang , isSrcUnpacked want_unpack, not (is_strict strict_mark) - = addDiagnosticTc WarningWithoutFlag (bad_bang n (text "UNPACK pragma lacks '!'")) + = addDiagnosticTc $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) | HsSrcBang _ want_unpack _ <- bang , isSrcUnpacked want_unpack @@ -4416,7 +4422,8 @@ -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addDiagnosticTc WarningWithoutFlag (bad_bang n (text "Ignoring unusable UNPACK pragma")) + = addDiagnosticTc $ TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma")) | otherwise = return () @@ -4475,17 +4482,18 @@ ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType = unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True - ; checkTc allowedArgType $ vcat + ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ] ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags ; let check_con what msg = - checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + checkTc what $ TcRnUnknownMessage $ mkPlainError noHints $ + (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) ; checkTc (ok_mult (scaledMult arg_ty1)) $ - text "A newtype constructor must be linear" + TcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear" ; check_con (null eq_spec) $ text "A newtype constructor must have a return type of form T a1 ... an" @@ -4540,7 +4548,7 @@ ; unless undecidable_super_classes $ case checkClassCycles cls of Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc err + addErrTc (TcRnUnknownMessage $ mkPlainError noHints err) Nothing -> return () -- Check the class operations. @@ -4568,12 +4576,12 @@ -- newBoard :: MonadState b m => m () -- Here, MonadState has a fundep m->b, so newBoard is fine - -- a method cannot be levity polymorphic, as we have to store the - -- method in a dictionary + -- a method cannot be representation-polymorphic, as we have to + -- store the method in a dictionary -- example of what this prevents: -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - ; checkForLevPoly empty tau1 + -- See Note [Representation polymorphism checking] in GHC.HsToCore.Monad + ; checkForLevPoly LevityCheckInValidClass tau1 ; unless constrained_class_methods $ mapM_ check_constraint (tail (cls_pred:op_theta)) @@ -4683,6 +4691,7 @@ -- default foo2 :: a -> b unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ + TcRnUnknownMessage $ mkPlainError noHints $ hang (text "The default type signature for" <+> ppr sel_id <> colon) 2 (ppr dm_ty) @@ -4701,13 +4710,15 @@ = do { idx_tys <- xoptM LangExt.TypeFamilies ; checkTc idx_tys err_msg } where - err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") + err_msg :: TcRnMessage + err_msg = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) + 2 (text "Enable TypeFamilies to allow indexed type families") checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () checkResultSigFlag tc_name (TyVarSig _ tvb) = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ + ; checkTc ty_fam_deps $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) 2 (text "Enable TypeFamilyDependencies to allow result variable names") } checkResultSigFlag _ _ = return () -- other cases OK @@ -5025,9 +5036,10 @@ check_ty_roles env role ty report_error doc - = addErrTc $ vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Internal error in role inference:", + doc, + text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] {- ************************************************************************ @@ -5106,15 +5118,17 @@ ctxt = text "In the equations for closed type family" <+> quotes (ppr tc) -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage resultTypeMisMatch field_name con1 con2 - = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "have a common field" <+> quotes (ppr field_name) <> comma], nest 2 $ text "but have different result types"] -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage fieldTypeMisMatch field_name con1 con2 - = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] dataConCtxt :: [LocatedN Name] -> SDoc @@ -5133,88 +5147,101 @@ classOpCtxt sel_id tau = sep [text "When checking the class method:", nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] -classArityErr :: Int -> Class -> SDoc +classArityErr :: Int -> Class -> TcRnMessage classArityErr n cls | n == 0 = mkErr "No" "no-parameter" | otherwise = mkErr "Too many" "multi-parameter" where - mkErr howMany allowWhat = + mkErr howMany allowWhat = TcRnUnknownMessage $ mkPlainError noHints $ vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), parens (text ("Enable MultiParamTypeClasses to allow " ++ allowWhat ++ " classes"))] -classFunDepsErr :: Class -> SDoc +classFunDepsErr :: Class -> TcRnMessage classFunDepsErr cls - = vcat [text "Fundeps in class" <+> quotes (ppr cls), + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [text "Fundeps in class" <+> quotes (ppr cls), parens (text "Enable FunctionalDependencies to allow fundeps")] -badMethPred :: Id -> TcPredType -> SDoc +badMethPred :: Id -> TcPredType -> TcRnMessage badMethPred sel_id pred - = vcat [ hang (text "Constraint" <+> quotes (ppr pred) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Constraint" <+> quotes (ppr pred) <+> text "in the type of" <+> quotes (ppr sel_id)) 2 (text "constrains only the class type variables") , text "Enable ConstrainedClassMethods to allow it" ] -noClassTyVarErr :: Class -> TyCon -> SDoc +noClassTyVarErr :: Class -> TyCon -> TcRnMessage noClassTyVarErr clas fam_tc - = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) , text "mentions none of the type or kind variables of the class" <+> quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] -badDataConTyCon :: DataCon -> Type -> SDoc +badDataConTyCon :: DataCon -> Type -> TcRnMessage badDataConTyCon data_con res_ty_tmpl - = hang (text "Data constructor" <+> quotes (ppr data_con) <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Data constructor" <+> quotes (ppr data_con) <+> text "returns type" <+> quotes (ppr actual_res_ty)) 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) where actual_res_ty = dataConOrigResTy data_con -badGadtDecl :: Name -> SDoc +badGadtDecl :: Name -> TcRnMessage badGadtDecl tc_name - = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] -badExistential :: DataCon -> SDoc +badExistential :: DataCon -> TcRnMessage badExistential con - = sdocOption sdocLinearTypes (\show_linear_types -> + = TcRnUnknownMessage $ mkPlainError noHints $ + sdocOption sdocLinearTypes (\show_linear_types -> hang (text "Data constructor" <+> quotes (ppr con) <+> text "has existential type variables, a context, or a specialised result type") 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con) , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) -badStupidTheta :: Name -> SDoc +badStupidTheta :: Name -> TcRnMessage badStupidTheta tc_name - = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) + = TcRnUnknownMessage $ mkPlainError noHints $ + text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) -newtypeConError :: Name -> Int -> SDoc +newtypeConError :: Name -> Int -> TcRnMessage newtypeConError tycon n - = sep [text "A newtype must have exactly one constructor,", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "A newtype must have exactly one constructor,", nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] -newtypeStrictError :: DataCon -> SDoc +newtypeStrictError :: DataCon -> TcRnMessage newtypeStrictError con - = sep [text "A newtype constructor cannot have a strictness annotation,", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "A newtype constructor cannot have a strictness annotation,", nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] -newtypeFieldErr :: DataCon -> Int -> SDoc +newtypeFieldErr :: DataCon -> Int -> TcRnMessage newtypeFieldErr con_name n_flds - = sep [text "The constructor of a newtype must have exactly one field", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [text "The constructor of a newtype must have exactly one field", nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] -badSigTyDecl :: Name -> SDoc +badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name - = vcat [ text "Illegal kind signature" <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal kind signature" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] -emptyConDeclsErr :: Name -> SDoc +emptyConDeclsErr :: Name -> TcRnMessage emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> text "has no constructors", + = TcRnUnknownMessage $ mkPlainError noHints $ + sep [quotes (ppr tycon) <+> text "has no constructors", nest 2 $ text "(EmptyDataDecls permits this)"] -wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily :: TyCon -> TcRnMessage wrongKindOfFamily family - = text "Wrong category of family instance; declaration was for a" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Wrong category of family instance; declaration was for a" <+> kindOfFamily where kindOfFamily | isTypeFamilyTyCon family = text "type family" @@ -5224,21 +5251,24 @@ -- | Produce an error for oversaturated type family equations with too many -- required arguments. -- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". -wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr :: Arity -> TcRnMessage wrongNumberOfParmsErr max_args - = text "Number of parameters must match family declaration; expected" + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Number of parameters must match family declaration; expected" <+> ppr max_args -badRoleAnnot :: Name -> Role -> Role -> SDoc +badRoleAnnot :: Name -> Role -> Role -> TcRnMessage badRoleAnnot var annot inferred - = hang (text "Role mismatch on variable" <+> ppr var <> colon) + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Role mismatch on variable" <+> ppr var <> colon) 2 (sep [ text "Annotation says", ppr annot , text "but role", ppr inferred , text "is required" ]) -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc +wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = hang (text "Wrong number of roles listed in role annotation;" $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) @@ -5248,22 +5278,26 @@ illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpanA loc $ - addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") -needXRoleAnnotations :: TyCon -> SDoc +needXRoleAnnotations :: TyCon -> TcRnMessage needXRoleAnnotations tc - = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal role annotation for" <+> ppr tc <> char ';' $$ text "did you intend to use RoleAnnotations?" -incoherentRoles :: SDoc -incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") +incoherentRoles :: TcRnMessage +incoherentRoles = TcRnUnknownMessage $ mkPlainError noHints $ + (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") $$ + (text "Use IncoherentInstances to allow this; bad role found") -wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName :: Name -> Name -> TcRnMessage wrongTyFamName fam_tc_name eqn_tc_name - = hang (text "Mismatched type name in type family instance.") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Mismatched type name in type family instance.") 2 (vcat [ text "Expected:" <+> ppr fam_tc_name , text " Actual:" <+> ppr eqn_tc_name ]) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Types.Evidence ( idHsWrapper ) import GHC.Tc.Gen.Bind @@ -50,6 +51,7 @@ import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env @@ -112,8 +114,8 @@ ************************************************************************ -} -illegalHsigDefaultMethod :: Name -> SDoc -illegalHsigDefaultMethod n = +illegalHsigDefaultMethod :: Name -> TcRnMessage +illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" tcClassSigs :: Name -- Name of the class @@ -274,10 +276,10 @@ ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags - ; diagnosticTc WarningWithoutFlag - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) + ; let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints $ + (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name)) + ; diagnosticTc (not (null spec_prags)) dia ; let hs_ty = hs_sig_fn sel_name `orElse` pprPanic "tc_dm" (ppr sel_name) @@ -353,7 +355,7 @@ -- since you can't write a default implementation. when (tcg_src tcg_env /= HsigFile) $ whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addDiagnosticTc WarningWithoutFlag (warningMinimalDefIncomplete bf)) + (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf)) return mindef where -- By default require all methods without a default implementation @@ -454,14 +456,16 @@ ************************************************************************ -} -badMethodErr :: Outputable a => a -> Name -> SDoc +badMethodErr :: Outputable a => a -> Name -> TcRnMessage badMethodErr clas op - = hsep [text "Class", quotes (ppr clas), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Class", quotes (ppr clas), text "does not have a method", quotes (ppr op)] -badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod :: Outputable a => a -> Name -> TcRnMessage badGenericMethod clas op - = hsep [text "Class", quotes (ppr clas), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Class", quotes (ppr clas), text "has a generic-default signature without a binding", quotes (ppr op)] {- @@ -485,13 +489,15 @@ -} badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> text "for default method" + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ + text "The" <+> hsSigDoc prag <+> text "for default method" <+> quotes (ppr sel_id) <+> text "lacks an accompanying binding") -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc +warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage warningMinimalDefIncomplete mindef - = vcat [ text "The MINIMAL pragma does not require:" + = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + vcat [ text "The MINIMAL pragma does not require:" , nest 2 (pprBooleanFormulaNice mindef) , text "but there is no default implementation." ] @@ -572,7 +578,10 @@ -- hs-boot and signatures never need to provide complete "definitions" -- of any sort, as they aren't really defining anything, but just -- constraining items which are defined elsewhere. - ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) } + ; let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $ + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name)) + ; diagnosticTc (warn && hsc_src == HsSrcFile) dia + } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -22,6 +22,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) @@ -60,6 +61,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class +import GHC.Types.Error import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -68,7 +70,6 @@ import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Utils.Error import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id @@ -1330,7 +1331,7 @@ con_app = mkLams dfun_bndrs $ mkApps (Var (dataConWrapId dict_con)) dict_args -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + -- See Note [Representation polymorphism checking] in GHC.HsToCore.Monad dict_args = map Type inst_tys ++ [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -1995,9 +1996,10 @@ , text " Class sig:" <+> ppr meth_ty ]) ; return (env2, msg) } -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc +misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage misplacedInstSig name hs_ty - = vcat [ hang (text "Illegal type signature in instance declaration:") + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Illegal type signature in instance declaration:") 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) , text "(Use InstanceSigs to allow this)" ] @@ -2080,8 +2082,7 @@ -- See Note [Default methods in instances] for why we use -- visible type application here mkDefMethBind dfun_id clas sel_id dm_name - = do { dflags <- getDynFlags - ; logger <- getLogger + = do { logger <- getLogger ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag @@ -2098,7 +2099,7 @@ bind = noLocA $ mkTopFunBind Generated fn $ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body" + ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body" FormatHaskell (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) @@ -2124,7 +2125,9 @@ warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods - ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) warn message + ; let msg = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message + ; diagnosticTc warn msg } where message = vcat [text "No explicit implementation for" @@ -2343,26 +2346,30 @@ inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) -badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr :: TcRnMessage badBootFamInstDeclErr - = text "Illegal family instance in hs-boot file" + = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" -notFamily :: TyCon -> SDoc +notFamily :: TyCon -> TcRnMessage notFamily tycon - = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] -assocInClassErr :: TyCon -> SDoc +assocInClassErr :: TyCon -> TcRnMessage assocInClassErr name - = text "Associated type" <+> quotes (ppr name) <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Associated type" <+> quotes (ppr name) <+> text "must be inside a class instance" -badFamInstDecl :: TyCon -> SDoc +badFamInstDecl :: TyCon -> TcRnMessage badFamInstDecl tc_name - = vcat [ text "Illegal family instance for" <+> + = TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal family instance for" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] -notOpenFamily :: TyCon -> SDoc +notOpenFamily :: TyCon -> TcRnMessage notOpenFamily tc - = text "Illegal instance for closed family" <+> quotes (ppr tc) + = TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -25,12 +25,14 @@ import GHC.Core.Multiplicity import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim +import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc @@ -58,6 +60,7 @@ import GHC.Core.ConLike import GHC.Types.FieldLabel import GHC.Rename.Env +import GHC.Rename.Utils (wrapGenSpan) import GHC.Data.Bag import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors ) @@ -226,6 +229,7 @@ -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) = failWithTc $ -- fail here: otherwise we get downstream errors + TcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" , hang (text "Pattern-bound variable") 2 (ppr arg <+> dcolon <+> ppr (idType arg)) @@ -370,7 +374,7 @@ -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity (decl_arity above) ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs - ; checkTc (null bad_tvs) $ + ; checkTc (null bad_tvs) $ TcRnUnknownMessage $ mkPlainError noHints $ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma , text "namely" <+> quotes (ppr pat_ty) ]) 2 (text "mentions existential type variable" <> plural bad_tvs @@ -645,7 +649,7 @@ wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" <+> speakNOf decl_arity (text "argument")) 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") @@ -878,7 +882,7 @@ = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ + = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" <+> quotes (ppr ps_name) <> colon) 2 why @@ -1024,10 +1028,9 @@ | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat - go1 p@(ListPat reb pats) - | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExtField exprs } - | otherwise = notInvertibleListPat p + go1 (ListPat _ pats) + = do { exprs <- mapM go pats + ; return $ ExplicitList noExtField exprs } go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField (map (Present noAnn) exprs) box } @@ -1044,13 +1047,21 @@ go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" + go1 (XPat (HsPatExpanded _ pat))= go1 pat + -- See Note [Invertible view patterns] + go1 p@(ViewPat mbInverse _ pat) = case mbInverse of + Nothing -> notInvertible p + Just inverse -> + fmap + (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr)) + (go1 (unLoc pat)) + -- The following patterns are not invertible. go1 p@(BangPat {}) = notInvertible p -- #14112 go1 p@(LazyPat {}) = notInvertible p go1 p@(WildPat {}) = notInvertible p go1 p@(AsPat {}) = notInvertible p - go1 p@(ViewPat {}) = notInvertible p go1 p@(NPlusKPat {}) = notInvertible p go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p @@ -1069,27 +1080,23 @@ pp_name = ppr name pp_args = hsep (map ppr args) - -- We should really be able to invert list patterns, even when - -- rebindable syntax is on, but doing so involves a bit of - -- refactoring; see #14380. Until then we reject with a - -- helpful error message. - notInvertibleListPat p - = Left (vcat [ not_invertible_msg p - , text "Reason: rebindable syntax is on." - , text "This is fixable: add use-case to #14380" ]) {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a bidirectional pattern synonym we need to produce an /expression/ -that matches the supplied /pattern/, given values for the arguments -of the pattern synonym. For example +For a bidirectional pattern synonym, the function 'tcPatToExpr' +needs to produce an /expression/ that matches the supplied /pattern/, +given values for the arguments of the pattern synonym. For example: pattern F x y = (Just x, [y]) The 'builder' for F looks like $builderF x y = (Just x, [y]) We can't always do this: - * Some patterns aren't invertible; e.g. view patterns - pattern F x = (reverse -> x:_) + * Some patterns aren't invertible; e.g. general view patterns + pattern F x = (f -> x) + as we don't have the ability to write down an expression that matches + the view pattern specified by an arbitrary view function `f`. + It is however sometimes possible to write down an inverse; + see Note [Invertible view patterns]. * The RHS pattern might bind more variables than the pattern synonym, so again we can't invert it @@ -1098,7 +1105,22 @@ * Ditto wildcards pattern F x = (x,_) +Note [Invertible view patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some view patterns, such as those that arise from expansion of overloaded +patterns (as detailed in Note [Handling overloaded and rebindable patterns]), +we are able to explicitly write out an inverse (in the sense of the previous +Note [Builder for a bidirectional pattern synonym]). +For instance, the inverse to the pattern + (toList -> [True, False]) + +is the expression + + (fromListN 2 [True,False]) + +Keeping track of the inverse for such view patterns fixed #14380. + Note [Redundant constraints for builder] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The builder can have redundant constraints, which are awkward to eliminate. @@ -1211,7 +1233,9 @@ = merge (cpt_tvs con', cpt_dicts con') $ goConDetails $ pat_args con go1 (SigPat _ p _) = go p - go1 (XPat (CoPat _ p _)) = go1 p + go1 (XPat ext) = case ext of + CoPat _ p _ -> go1 p + ExpansionPat _ p -> go1 p go1 (NPlusKPat _ n k _ geq subtract) = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract go1 _ = empty diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -29,6 +29,7 @@ import GHC.Prelude +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds ) @@ -64,6 +65,7 @@ import GHC.Unit.Module import GHC.Types.Basic +import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -204,7 +206,7 @@ checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc err + Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right _ -> return () where -- Try our best to print the LTyClDecl for locally defined things diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs --- a/compiler/GHC/Tc/Types/EvTerm.hs +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -13,34 +13,27 @@ import GHC.Unit import GHC.Builtin.Names -import GHC.Builtin.Types ( liftedRepTy, unitTy ) +import GHC.Builtin.Types ( unitTy ) import GHC.Core.Type import GHC.Core import GHC.Core.Make import GHC.Core.Utils -import GHC.Types.Literal ( Literal(..) ) import GHC.Types.SrcLoc import GHC.Types.Name import GHC.Types.TyThing -import GHC.Data.FastString - -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] -- in GHC.Tc.Solver -evDelayedError :: Type -> FastString -> EvTerm +evDelayedError :: Type -> String -> EvTerm evDelayedError ty msg = EvExpr $ - let fail_expr = Var errorId `mkTyApps` [liftedRepTy, unitTy] `mkApps` [litMsg] + let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg in mkWildCase fail_expr (unrestricted unitTy) ty [] -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils - -- c.f. mkFailExpr in GHC.HsToCore.Utils - - where - errorId = tYPE_ERROR_ID - litMsg = Lit (LitString (bytesFS msg)) + -- c.f. mkErrorAppDs in GHC.HsToCore.Utils -- Dictionary for CallStack implicit parameters evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -21,6 +21,7 @@ import GHC.Driver.Env import GHC.Driver.Ppr +import GHC.Driver.Session import GHC.Types.Basic (TypeOrKind(..)) import GHC.Types.Fixity (defaultFixity) @@ -39,7 +40,6 @@ import GHC.Types.Name.Shape import GHC.Unit -import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface @@ -47,6 +47,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Export import GHC.Tc.Solver import GHC.Tc.TyCl.Utils @@ -89,8 +90,9 @@ import {-# SOURCE #-} GHC.Tc.Module -fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc +fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage fixityMisMatch real_thing real_fixity sig_fixity = + TcRnUnknownMessage $ mkPlainError noHints $ vcat [ppr real_thing <+> text "has conflicting fixities in the module", text "and its hsig file", text "Main module:" <+> ppr_fix real_fixity, @@ -132,6 +134,7 @@ traceTc "checkHsigIface" $ vcat [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] mapM_ check_export (map availName sig_exports) + failIfErrsM -- See Note [Fail before checking instances in checkHsigIface] unless (null sig_fam_insts) $ panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++ "instances in hsig files yet...") @@ -166,7 +169,7 @@ -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr err + Failed err -> addErr (TcRnUnknownMessage $ mkPlainError noHints err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must @@ -192,6 +195,14 @@ addErrAt (nameSrcSpan name) (missingBootThing False name "exported by") +-- Note [Fail before checking instances in checkHsigIface] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We need to be careful about failing before checking instances if there happens +-- to be an error in the exports. +-- Otherwise, we might proceed with typechecking (and subsequently panic-ing) on +-- ill-kinded types that are constructed while checking instances. +-- This lead to #19244 + -- Note [Error reporting bad reexport] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- NB: You want to be a bit careful about what location you report on reexports. @@ -272,11 +283,12 @@ findExtraSigImports' hsc_env HsigFile modname = fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) -> (initIfaceLoad hsc_env - . withException dflags + . withException ctx $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name))) where dflags = hsc_dflags hsc_env + ctx = initSDocContext dflags defaultUserStyle unit_state = hsc_units hsc_env reqs = requirementMerges unit_state modname @@ -371,7 +383,7 @@ HscEnv -> Unit -> IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid = - withTiming logger dflags + withTiming logger (text "Check unit id" <+> ppr uid) (const ()) $ initTc hsc_env @@ -392,13 +404,12 @@ tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming logger dflags + withTiming logger (text "Signature merging" <+> brackets (ppr this_mod)) (const ()) $ initTc hsc_env HsigFile False this_mod real_loc $ mergeSignatures hpm orig_tcg_env iface where - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env this_mod = mi_module iface real_loc = tcg_top_loc orig_tcg_env @@ -588,8 +599,9 @@ ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do let m = mkModule (VirtUnit iuid) mod_name im = fst (getModuleInstantiation m) + ctx = initSDocContext dflags defaultUserStyle fmap fst - . withException dflags + . withException ctx $ findAndReadIface logger nc fc hooks unit_state home_unit dflags (text "mergeSignatures") im m NotBoot @@ -703,7 +715,7 @@ -- 3(d). Extend the name substitution (performing shaping) mb_r <- extend_ns nsubst as2 case mb_r of - Left err -> failWithTc err + Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) @@ -930,12 +942,11 @@ HscEnv -> Module -> RealSrcSpan -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming logger dflags + withTiming logger (text "Signature instantiation"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature where - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env exportOccs :: [AvailInfo] -> [OccName] @@ -1014,7 +1025,7 @@ isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ + Failed err -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Could not find hi interface for signature" <+> quotes (ppr isig_mod) <> colon) 4 err @@ -1022,7 +1033,8 @@ -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ quotes (ppr occ) + [] -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + quotes (ppr occ) <+> text "is exported by the hsig file, but not exported by the implementing module" <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) _ -> return () 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 @@ -85,6 +85,7 @@ import GHC.Iface.Env import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -128,6 +129,7 @@ import GHC.Types.Var.Env import GHC.Types.Name.Reader import GHC.Types.TyThing +import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt import Data.IORef @@ -254,7 +256,7 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc msg + Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. @@ -324,10 +326,12 @@ tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ text "Couldn't match instance:" <+> err + Left err -> + failWithTc $ TcRnUnknownMessage + $ mkPlainError noHints (text "Couldn't match instance:" <+> err) Right (inst, tys) | uniqueTyVars tys -> return inst - | otherwise -> failWithTc errNotExact + | otherwise -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact) } where errNotExact = text "Not an exact match (i.e., some variables get instantiated)" @@ -874,6 +878,7 @@ | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) + TcRnUnknownMessage $ mkPlainError noHints $ text "Stage error:" <+> pp_thing <+> hsep [text "is bound at stage" <+> ppr bind_lvl, text "but used at stage" <+> ppr use_lvl] @@ -881,6 +886,7 @@ stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing = failWithTc $ + TcRnUnknownMessage $ mkPlainError noHints $ sep [ text "GHC stage restriction:" , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," , text "and must be imported, not defined locally"])] @@ -1148,6 +1154,7 @@ -- don't report it again (#11941) | otherwise -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ + TcRnUnknownMessage $ mkPlainError noHints $ vcat[text "GHC internal error:" <+> quotes (ppr name) <+> text "is not in scope during type checking, but it passed the renamer", text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] @@ -1163,8 +1170,10 @@ -- turn does not look at the details of the TcTyThing. -- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) + = let msg = TcRnUnknownMessage $ mkPlainError noHints $ + (pprTcTyThingCategory thing <+> quotes (ppr name) <+> + text "used as a" <+> text expected) + in failWithTc msg {- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -47,6 +47,7 @@ import GHC.Builtin.Names import GHC.Hs +import GHC.Hs.Syn.Type ( hsLitType ) import GHC.Core.InstEnv import GHC.Core.Predicate @@ -69,9 +70,11 @@ import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType +import GHC.Tc.Errors.Types import GHC.Types.Id.Make( mkDictFunId ) import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env @@ -821,14 +824,13 @@ ; oflag <- getOverlapFlag overlap_mode ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIfFlag Opt_WarnOrphans - (isOrphan (is_orphan inst)) - (instOrphWarn inst) + ; warnIf (isOrphan (is_orphan inst)) (instOrphWarn inst) ; return inst } -instOrphWarn :: ClsInst -> SDoc +instOrphWarn :: ClsInst -> TcRnMessage instOrphWarn inst - = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) + = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnOrphans) noHints $ + hang (text "Orphan instance:") 2 (pprInstanceHdr inst) $$ text "To avoid this" $$ nest 4 (vcat possibilities) where @@ -966,7 +968,8 @@ addClsInstsErr herald ispecs = do unit_state <- hsc_units <$> getTopEnv setSrcSpan (getSrcSpan (head sorted)) $ - addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) where sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs -- The sortBy just arranges that instances are displayed in order 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 @@ -21,6 +21,7 @@ discardResult, getTopEnv, updTopEnv, getGblEnv, updGblEnv, setGblEnv, getLclEnv, updLclEnv, setLclEnv, + updTopFlags, getEnvs, setEnvs, xoptM, doptM, goptM, woptM, setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, @@ -57,7 +58,7 @@ getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getRecFieldEnv, getDeclaredDefaultTys, - addDependentFiles, + addDependentFiles, getMnwib, -- * Error management getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode, @@ -75,7 +76,6 @@ tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkTcRnMessage, addLongErrAt, reportDiagnostic, reportDiagnostics, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs, @@ -86,15 +86,17 @@ getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, - -- * Error message generation (type checker) + -- * Diagnostic message generation (type checker) addErrTc, addErrTcM, failWithTc, failWithTcM, checkTc, checkTcM, failIfTc, failIfTcM, - warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, addDetailedDiagnostic, addTcRnDiagnostic, - addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, add_diagnostic, mkErrInfo, + addTcRnDiagnostic, addDetailedDiagnostic, + mkTcRnMessage, reportDiagnostic, reportDiagnostics, + warnIf, diagnosticTc, diagnosticTcM, + addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, -- * Type constraints newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, @@ -172,8 +174,8 @@ import GHC.Core.FamInstEnv import GHC.Driver.Env -import GHC.Driver.Ppr import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic import GHC.Runtime.Context @@ -266,10 +268,11 @@ -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ; !home_unit = hsc_home_unit hsc_env ; + !logger = hsc_logger hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val + | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val | gopt Opt_WriteHie dflags = Just empty_val @@ -499,32 +502,30 @@ -- Command-line flags xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } +xoptM flag = xopt flag <$> getDynFlags doptM :: DumpFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } +doptM flag = do + logger <- getLogger + return (logHasDumpFlag logger flag) goptM :: GeneralFlag -> TcRnIf gbl lcl Bool -goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } +goptM flag = gopt flag <$> getDynFlags woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } +woptM flag = wopt flag <$> getDynFlags setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) +setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag) unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) +unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag) unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetGOptM flag = - updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) +unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag) unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetWOptM flag = - updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) +unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag) -- | Do it flag is true whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () @@ -554,13 +555,14 @@ {-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities] getGhcMode :: TcRnIf gbl lcl GhcMode -getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } +getGhcMode = ghcMode <$> getDynFlags withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a -withoutDynamicNow = - updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> - top { hsc_dflags = dflags { dynamicNow = False} }) +withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False}) +updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopFlags f = updTopEnv (hscUpdateFlags f) + getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) getEpsVar = do env <- getTopEnv @@ -598,11 +600,11 @@ -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error. -withException :: MonadIO m => DynFlags -> m (MaybeErr SDoc a) -> m a -withException dflags do_this = do +withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a +withException ctx do_this = do r <- do_this case r of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err)) Succeeded result -> return result {- @@ -777,21 +779,20 @@ -- dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle flag title fmt doc = do - dflags <- getDynFlags logger <- getLogger printer <- getPrintUnqualified real_doc <- wrapDocLoc doc let sty = if useUserStyle then mkUserStyle printer AllTheWay else mkDumpStyle printer - liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc + liftIO $ logDumpFile logger sty flag title fmt real_doc -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much) wrapDocLoc :: SDoc -> TcRn SDoc wrapDocLoc doc = do - dflags <- getDynFlags - if hasPprDebug dflags + logger <- getLogger + if logHasDumpFlag logger Opt_D_ppr_debug then do loc <- getSrcSpanM return (mkLocMessage MCOutput loc doc) @@ -807,10 +808,9 @@ -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do - dflags <- getDynFlags logger <- getLogger printer <- getPrintUnqualified - liftIO (printOutputForUser logger dflags printer doc) + liftIO (printOutputForUser logger printer doc) {- traceIf works in the TcRnIf monad, where no RdrEnv is @@ -826,9 +826,8 @@ traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc = whenDOptM flag $ do -- No RdrEnv available, so qualify everything - dflags <- getDynFlags logger <- getLogger - liftIO (putMsg logger dflags doc) + liftIO (putMsg logger doc) {-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] {- @@ -899,6 +898,11 @@ -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) } +getMnwib :: TcRn ModuleNameWithIsBoot +getMnwib = do + gbl_env <- getGblEnv + return $ GWIB (moduleName $ tcg_mod gbl_env) (hscSourceToIsBoot (tcg_src gbl_env)) + -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv @@ -976,30 +980,30 @@ setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: SDoc -> TcRn () +addErr :: TcRnMessage -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: SDoc -> TcRn a +failWith :: TcRnMessage -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> SDoc -> TcRn a +failAt :: SrcSpan -> TcRnMessage -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> SDoc -> TcRn () +addErrAt :: SrcSpan -> TcRnMessage -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- tcInitTidyEnv ; err_info <- mkErrInfo tidy_env ctxt - ; addLongErrAt loc msg err_info } + ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } -addErrs :: [(SrcSpan,SDoc)] -> TcRn () +addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> SDoc -> TcRn () +checkErr :: Bool -> TcRnMessage -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) @@ -1032,37 +1036,24 @@ ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope TcRnMessage) -mkLongErrAt loc msg extra - = do { printer <- getPrintUnqualified ; - unit_state <- hsc_units <$> getTopEnv ; - let msg' = pprWithUnitState unit_state msg in - return $ mkErrorMsgEnvelope loc printer - $ TcRnUnknownMessage - $ mkDecoratedError noHints [msg', extra] } +add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn () +add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic + where + mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage) + mk_long_err_at loc msg + = do { printer <- getPrintUnqualified ; + unit_state <- hsc_units <$> getTopEnv ; + return $ mkErrorMsgEnvelope loc printer + $ TcRnMessageWithInfo unit_state msg + } -mkTcRnMessage :: DiagnosticReason - -> SrcSpan - -> SDoc - -- ^ The important part of the message - -> SDoc - -- ^ The context of the message - -> SDoc - -- ^ Any supplementary information. +mkTcRnMessage :: SrcSpan + -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage) -mkTcRnMessage reason loc important context extra +mkTcRnMessage loc msg = do { printer <- getPrintUnqualified ; - unit_state <- hsc_units <$> getTopEnv ; - dflags <- getDynFlags ; - let errDocs = map (pprWithUnitState unit_state) - [important, context, extra] - in - return $ mkMsgEnvelope dflags loc printer - $ TcRnUnknownMessage - $ mkDecoratedDiagnostic reason noHints errDocs } - -addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic + diag_opts <- initDiagOpts <$> getDynFlags ; + return $ mkMsgEnvelope diag_opts loc printer msg } reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic @@ -1468,11 +1459,11 @@ tidy up the message; we then use it to tidy the context messages -} -addErrTc :: SDoc -> TcM () +addErrTc :: TcRnMessage -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, SDoc) -> TcM () +addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; @@ -1480,27 +1471,27 @@ -- The failWith functions add an error message and cause failure -failWithTc :: SDoc -> TcM a -- Add an error message and fail +failWithTc :: TcRnMessage -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, SDoc) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> SDoc -> TcM () -- Check that the boolean is true +checkTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM () +checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () checkTcM True _ = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> SDoc -> TcM () -- Check that the boolean is false +failIfTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is false failIfTc False _ = return () failIfTc True err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM () +failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () -- Check that the boolean is false failIfTcM False _ = return () failIfTcM True err = failWithTcM err @@ -1508,46 +1499,39 @@ -- Warnings have no 'M' variant, nor failure --- | Display a warning if a condition is met, --- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () -warnIfFlag warn_flag is_bad msg - = do { -- No need to check the flag here, it will be done in 'diagReasonSeverity'. - ; when is_bad $ addDiagnostic (WarningWithFlag warn_flag) msg } - -- | Display a warning if a condition is met. -warnIf :: Bool -> SDoc -> TcRn () -warnIf is_bad msg - = when is_bad (addDiagnostic WarningWithoutFlag msg) +warnIf :: Bool -> TcRnMessage -> TcRn () +warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'. + = when is_bad (addDiagnostic msg) +no_err_info :: ErrInfo +no_err_info = ErrInfo Outputable.empty Outputable.empty + -- | Display a warning if a condition is met. -diagnosticTc :: DiagnosticReason -> Bool -> SDoc -> TcM () -diagnosticTc reason should_report warn_msg - | should_report = addDiagnosticTc reason warn_msg +diagnosticTc :: Bool -> TcRnMessage -> TcM () +diagnosticTc should_report warn_msg + | should_report = addDiagnosticTc warn_msg | otherwise = return () -- | Display a diagnostic if a condition is met. -diagnosticTcM :: DiagnosticReason -> Bool -> (TidyEnv, SDoc) -> TcM () -diagnosticTcM reason should_report warn_msg - | should_report = addDiagnosticTcM reason warn_msg +diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () +diagnosticTcM should_report warn_msg + | should_report = addDiagnosticTcM warn_msg | otherwise = return () -- | Display a diagnostic in the current context. -addDiagnosticTc :: DiagnosticReason -> SDoc -> TcM () -addDiagnosticTc reason msg +addDiagnosticTc :: TcRnMessage -> TcM () +addDiagnosticTc msg = do { env0 <- tcInitTidyEnv ; - addDiagnosticTcM reason (env0, msg) } + addDiagnosticTcM (env0, msg) } -- | Display a diagnostic in a given context. -addDiagnosticTcM :: DiagnosticReason -> (TidyEnv, SDoc) -> TcM () -addDiagnosticTcM reason (env0, msg) - = do { ctxt <- getErrCtxt ; - err_info <- mkErrInfo env0 ctxt ; - add_diagnostic reason msg err_info } - --- | Display a diagnostic for the current source location. -addDiagnostic :: DiagnosticReason -> SDoc -> TcRn () -addDiagnostic reason msg = add_diagnostic reason msg Outputable.empty +addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () +addDiagnosticTcM (env0, msg) + = do { ctxt <- getErrCtxt + ; extra <- mkErrInfo env0 ctxt + ; let err_info = ErrInfo extra Outputable.empty + ; add_diagnostic (TcRnMessageDetailed err_info msg) } -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic. @@ -1555,39 +1539,37 @@ addDetailedDiagnostic mkMsg = do loc <- getSrcSpanM printer <- getPrintUnqualified - dflags <- getDynFlags + !diag_opts <- initDiagOpts <$> getDynFlags env0 <- tcInitTidyEnv ctxt <- getErrCtxt err_info <- mkErrInfo env0 ctxt - reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info))) + reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty))) addTcRnDiagnostic :: TcRnMessage -> TcM () addTcRnDiagnostic msg = do loc <- getSrcSpanM - printer <- getPrintUnqualified - dflags <- getDynFlags - reportDiagnostic (mkMsgEnvelope dflags loc printer msg) + mkTcRnMessage loc msg >>= reportDiagnostic +-- | Display a diagnostic for the current source location, taken from +-- the 'TcRn' monad. +addDiagnostic :: TcRnMessage -> TcRn () +addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg) + -- | Display a diagnostic for a given source location. -addDiagnosticAt :: DiagnosticReason -> SrcSpan -> SDoc -> TcRn () -addDiagnosticAt reason loc msg = add_diagnostic_at reason loc msg Outputable.empty +addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () +addDiagnosticAt loc msg = do + unit_state <- hsc_units <$> getTopEnv + let dia = TcRnMessageDetailed no_err_info msg + mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic -- | Display a diagnostic, with an optional flag, for the current source -- location. -add_diagnostic :: DiagnosticReason -> SDoc -> SDoc -> TcRn () -add_diagnostic reason msg extra_info +add_diagnostic :: TcRnMessageDetailed -> TcRn () +add_diagnostic msg = do { loc <- getSrcSpanM - ; add_diagnostic_at reason loc msg extra_info } - --- | Display a diagnosticTc, with an optional flag, for a given location. -add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () -add_diagnostic_at reason loc msg extra_info - = do { printer <- getPrintUnqualified ; - dflags <- getDynFlags ; - let { dia = mkMsgEnvelope dflags loc printer $ - TcRnUnknownMessage $ - mkDecoratedDiagnostic reason noHints [msg, extra_info] } ; - reportDiagnostic dia } + ; unit_state <- hsc_units <$> getTopEnv + ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic + } {- @@ -1595,12 +1577,12 @@ Other helper functions -} -add_err_tcm :: TidyEnv -> SDoc -> SrcSpan +add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan -> [ErrCtxt] -> TcM () -add_err_tcm tidy_env err_msg loc ctxt +add_err_tcm tidy_env msg loc ctxt = do { err_info <- mkErrInfo tidy_env ctxt ; - addLongErrAt loc err_msg err_info } + add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts @@ -2129,9 +2111,8 @@ failIfM msg = do env <- getLclEnv let full_msg = (if_loc env <> colon) $$ nest 2 msg - dflags <- getDynFlags logger <- getLogger - liftIO (putLogMsg logger dflags MCFatal + liftIO (logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle full_msg) failM @@ -2161,11 +2142,10 @@ -- Otherwise we silently discard errors. Errors can legitimately -- happen when compiling interface signatures (see tcInterfaceSigs) whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags logger <- getLogger let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) - liftIO $ putLogMsg logger dflags + liftIO $ logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -92,49 +92,53 @@ candidateKindVars, partitionCandidates, ------------------------------ - -- Levity polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr + -- Representation polymorphism + ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, ) where --- friends: import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} ) +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad -- TcType, amongst others +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Errors.Types + import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr -import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Class -import GHC.Types.Var import GHC.Core.Predicate -import GHC.Tc.Types.Origin --- others: -import GHC.Tc.Utils.Monad -- TcType, amongst others -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence +import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name import GHC.Types.Var.Set + import GHC.Builtin.Types +import GHC.Types.Error import GHC.Types.Var.Env import GHC.Types.Name.Env +import GHC.Types.Unique.Set +import GHC.Types.Basic ( TypeOrKind(..) ) + +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.Pair + import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) -import GHC.Data.FastString -import GHC.Data.Bag -import GHC.Data.Pair -import GHC.Types.Unique.Set -import GHC.Driver.Session -import GHC.Driver.Ppr -import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Utils.Trace import Control.Monad import GHC.Data.Maybe @@ -363,7 +367,7 @@ unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref -- | Check that a coercion is appropriate for filling a hole. (The hole --- itself is needed only for printing. +-- itself is needed only for printing.) -- Always returns the checked coercion, but this return value is necessary -- so that the input coercion is forced only when the output is forced. checkCoercionHole :: CoVar -> Coercion -> TcM Coercion @@ -879,7 +883,7 @@ ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) ; return tyvar } --- Make a new CycleBreakerTv. See Note [Type variable cycles in Givens] +-- Make a new CycleBreakerTv. See Note [Type variable cycles] -- in GHC.Tc.Solver.Canonical. newCycleBreakerTyVar :: TcKind -> TcM TcTyVar newCycleBreakerTyVar kind @@ -1827,9 +1831,10 @@ ; writeMetaTyVar kv liftedTypeKind ; return True } | otherwise - = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) + = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') + , text "of kind:" <+> ppr (tyVarKind kv') + , text "Perhaps enable PolyKinds or add a kind signature" ]) -- We failed to default it, so return False to say so. -- Hence, it'll get skolemised. That might seem odd, but we must either -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType @@ -2017,12 +2022,13 @@ ; unless (null leftover_metas) $ do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let doc = vcat [ text "Uninferrable type variable" - <> plural tidied_tvs - <+> pprWithCommas pprTyVar tidied_tvs - <+> text "in" - , where_doc ] - ; failWithTcM (tidy_env2, pprWithExplicitKindsWhen True doc) } + ; let msg = TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $ + vcat [ text "Uninferrable type variable" + <> plural tidied_tvs + <+> pprWithCommas pprTyVar tidied_tvs + <+> text "in" + , where_doc ] + ; failWithTcM (tidy_env2, msg) } ; traceTc "doNotQuantifyTyVars success" empty } {- Note [Defaulting with -XNoPolyKinds] @@ -2323,7 +2329,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct. For example, - a CDictCan should stay a CDictCan; - - a CIrredCan should stay a CIrredCan with its cc_status flag intact + - a CIrredCan should stay a CIrredCan with its cc_reason flag intact Why?, for example: - For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the @@ -2356,7 +2362,7 @@ zonkCt (CEqCan { cc_ev = ev }) = mkNonCanonical <$> zonkCtEvidence ev -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag +zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag = do { ev' <- zonkCtEvidence ev ; return (ct { cc_ev = ev' }) } @@ -2606,11 +2612,11 @@ {- %************************************************************************ %* * - Levity polymorphism checks + Representation polymorphism checks * * ************************************************************************* -See Note [Levity polymorphism checking] in GHC.HsToCore.Monad +See Note [Representation polymorphism checking] in GHC.HsToCore.Monad -} @@ -2624,36 +2630,28 @@ -- isn't really a compositional property of a type system, so it's -- not a terrible surprise that the check has to go in an awkward spot. ensureNotLevPoly :: Type -- its zonked type - -> SDoc -- where this happened + -> LevityCheckProvenance -- where this happened -> TcM () -ensureNotLevPoly ty doc +ensureNotLevPoly ty provenance = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly doc ty + checkForLevPoly provenance ty - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad -checkForLevPoly :: SDoc -> Type -> TcM () -checkForLevPoly = checkForLevPolyX addErr + -- See Note [Representation polymorphism checking] in GHC.HsToCore.Monad +checkForLevPoly :: LevityCheckProvenance -> Type -> TcM () +checkForLevPoly = checkForLevPolyX (\ty -> addDetailedDiagnostic . TcLevityPolyInType ty) checkForLevPolyX :: Monad m - => (SDoc -> m ()) -- how to report an error - -> SDoc -> Type -> m () -checkForLevPolyX add_err extra ty + => (Type -> LevityCheckProvenance -> m ()) -- how to report an error + -> LevityCheckProvenance + -> Type + -> m () +checkForLevPolyX add_err provenance ty | isTypeLevPoly ty - = add_err (formatLevPolyErr ty $$ extra) + = add_err ty provenance | otherwise = return () -formatLevPolyErr :: Type -- levity-polymorphic type - -> SDoc -formatLevPolyErr ty - = hang (text "A levity-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty - , text "Kind:" <+> pprWithTYPE tidy_ki ]) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (tcTypeKind ty) - {- %************************************************************************ %* * @@ -2683,7 +2681,8 @@ orig_ty' = tidyType env orig_ty1 ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - doc = pprWithExplicitKindsWhen True $ + msg = TcRnUnknownMessage $ mkPlainError noHints $ + pprWithExplicitKindsWhen True $ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' , quotes $ ppr_tidied escapees' , text "would escape" <+> itsOrTheir escapees' <+> text "scope" @@ -2697,4 +2696,4 @@ , text " due to its ill-scoped nature.)" ] - ; failWithTcM (env, doc) } + ; failWithTcM (env, msg) } 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 @@ -1,5 +1,3 @@ - -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -36,8 +34,7 @@ matchExpectedFunKind, matchActualFunTySigma, matchActualFunTysRho, - occCheckForErrors, CheckTyEqResult(..), - checkTyVarEq, checkTyFamEq, checkTypeEq, AreTypeFamiliesOK(..) + checkTyVarEq, checkTyFamEq, checkTypeEq ) where @@ -55,7 +52,6 @@ import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Types.Name( isSystemName ) import GHC.Tc.Utils.Instantiate @@ -76,8 +72,7 @@ import GHC.Exts ( inline ) import Control.Monad import Control.Arrow ( second ) -import qualified Data.Semigroup as S - +import qualified Data.Semigroup as S ( (<>) ) {- ********************************************************************* * * @@ -562,7 +557,8 @@ -- If wrap = tc_sub_type_et t1 t2 -- => wrap :: t1 ~> t2 tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected - = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected + = do { dflags <- getDynFlags + ; tc_sub_type dflags unifyTypeET inst_orig ctxt ty_actual ty_expected } tcSubTypePat _ _ (Infer inf_res) ty_expected = do { co <- fillInferResult ty_expected inf_res @@ -589,8 +585,9 @@ -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of - Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt - ty_actual ty_expected + Check ty_expected -> do { dflags <- getDynFlags + ; tc_sub_type dflags (unifyType m_thing) inst_orig ctxt + ty_actual ty_expected } Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual -- See Note [Instantiation of InferResult] @@ -640,7 +637,8 @@ -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected tcSubTypeSigma ctxt ty_actual ty_expected - = tc_sub_type (unifyType Nothing) eq_orig ctxt ty_actual ty_expected + = do { dflags <- getDynFlags + ; tc_sub_type dflags (unifyType Nothing) eq_orig ctxt ty_actual ty_expected } where eq_orig = TypeEqOrigin { uo_actual = ty_actual , uo_expected = ty_expected @@ -648,7 +646,8 @@ , uo_visible = True } --------------- -tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify +tc_sub_type :: DynFlags + -> (TcType -> TcType -> TcM TcCoercionN) -- How to unify -> CtOrigin -- Used when instantiating -> UserTypeCtxt -- Used when skolemising -> TcSigmaType -- Actual; a sigma-type @@ -657,7 +656,7 @@ -- Checks that actual_ty is more polymorphic than expected_ty -- If wrap = tc_sub_type t1 t2 -- => wrap :: t1 ~> t2 -tc_sub_type unify inst_orig ctxt ty_actual ty_expected +tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] , not (possibly_poly ty_actual) = do { traceTc "tc_sub_type (drop to equality)" $ @@ -685,7 +684,7 @@ | (tvs, theta, tau) <- tcSplitSigmaTy ty , (tv:_) <- tvs , null theta - , isInsolubleOccursCheck NomEq tv tau + , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs = True | otherwise = False @@ -790,7 +789,7 @@ Why do we check this in the desugarer? It's a convenient place, since it's right after all the constraints are solved. We need the constraints to be solved to check whether they are trivial or not. Plus there is precedent for -type errors during desuraging (such as the levity polymorphism +type errors during desuraging (such as the representation polymorphism restriction). An alternative would be to have a kind of constraint which can only produce trivial evidence, then this check would happen in the constraint solver. @@ -1443,8 +1442,8 @@ | isTouchableMetaTyVar cur_lvl tv1 -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles , canSolveByUnification (metaTyVarInfo tv1) ty2 - , CTE_OK <- checkTyVarEq dflags NoTypeFamilies tv1 ty2 - -- See Note [Prevent unification with type families] about the NoTypeFamilies: + , cterHasNoProblem (checkTyVarEq dflags tv1 ty2) + -- See Note [Prevent unification with type families] = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1) ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) @@ -1607,7 +1606,7 @@ isTouchableMetaTyVar. * In the constraint solver, we track where Given equalities occur - and use that to guard unification in GHC.Tc.Solver.Canonical.unifyTest + and use that to guard unification in GHC.Tc.Solver.Canonical.touchabilityTest More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet Historical note: in the olden days (pre 2021) the constraint solver @@ -1763,7 +1762,7 @@ better in practice. Revisited in Nov '20, along with removing flattening variables. Problem -is still present, and the solution (NoTypeFamilies) is still the same. +is still present, and the solution is still the same. Note [Refactoring hazard: metaTyVarUpdateOK] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1891,7 +1890,7 @@ {- ********************************************************************* * * - Occurrence checking + Equality invariant checking * * ********************************************************************* -} @@ -1928,65 +1927,29 @@ -} -data CheckTyEqResult - = CTE_OK - | CTE_Bad -- Forall, predicate, or type family - | CTE_HoleBlocker -- Blocking coercion hole - -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" - | CTE_Occurs - -instance S.Semigroup CheckTyEqResult where - CTE_OK <> x = x - x <> _ = x - -instance Monoid CheckTyEqResult where - mempty = CTE_OK - -instance Outputable CheckTyEqResult where - ppr CTE_OK = text "CTE_OK" - ppr CTE_Bad = text "CTE_Bad" - ppr CTE_HoleBlocker = text "CTE_HoleBlocker" - ppr CTE_Occurs = text "CTE_Occurs" - -occCheckForErrors :: DynFlags -> TcTyVar -> Type -> CheckTyEqResult --- Just for error-message generation; so we return CheckTyEqResult --- so the caller can report the right kind of error --- Check whether --- a) the given variable occurs in the given type. --- b) there is a forall in the type (unless we have -XImpredicativeTypes) -occCheckForErrors dflags tv ty - = case checkTyVarEq dflags YesTypeFamilies tv ty of - CTE_Occurs -> case occCheckExpand [tv] ty of - Nothing -> CTE_Occurs - Just _ -> CTE_OK - other -> other - ---------------- -data AreTypeFamiliesOK = YesTypeFamilies - | NoTypeFamilies - deriving Eq - -instance Outputable AreTypeFamiliesOK where - ppr YesTypeFamilies = text "YesTypeFamilies" - ppr NoTypeFamilies = text "NoTypeFamilies" - -checkTyVarEq :: DynFlags -> AreTypeFamiliesOK -> TcTyVar -> TcType -> CheckTyEqResult -checkTyVarEq dflags ty_fam_ok tv ty - = inline checkTypeEq dflags ty_fam_ok (TyVarLHS tv) ty +{-# NOINLINE checkTyVarEq #-} -- checkTyVarEq becomes big after the `inline` fires +checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult +checkTyVarEq dflags tv ty + = inline checkTypeEq dflags (TyVarLHS tv) ty -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away +{-# NOINLINE checkTyFamEq #-} -- checkTyFamEq becomes big after the `inline` fires checkTyFamEq :: DynFlags -> TyCon -- type function -> [TcType] -- args, exactly saturated -> TcType -- RHS - -> CheckTyEqResult + -> CheckTyEqResult -- always drops cteTypeFamily checkTyFamEq dflags fun_tc fun_args ty - = inline checkTypeEq dflags YesTypeFamilies (TyFamLHS fun_tc fun_args) ty + = inline checkTypeEq dflags (TyFamLHS fun_tc fun_args) ty + `cterRemoveProblem` cteTypeFamily -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away -checkTypeEq :: DynFlags -> AreTypeFamiliesOK -> CanEqLHS -> TcType - -> CheckTyEqResult --- Checks the invariants for CEqCan. In particular: +checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult +-- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs +-- is a canonical CEqCan. +-- +-- In particular, this looks for: -- (a) a forall type (forall a. blah) -- (b) a predicate type (c => ty) -- (c) a type family; see Note [Prevent unification with type families] @@ -2010,9 +1973,15 @@ -- * checkTyFamEq, checkTyVarEq (which inline it to specialise away the -- case-analysis on 'lhs') -- * checkEqCanLHSFinish, which does not know the form of 'lhs' -checkTypeEq dflags ty_fam_ok lhs ty +checkTypeEq dflags lhs ty = go ty where + impredicative = cteProblem cteImpredicative + type_family = cteProblem cteTypeFamily + hole_blocker = cteProblem cteHoleBlocker + insoluble_occurs = cteProblem cteInsolubleOccurs + soluble_occurs = cteProblem cteSolubleOccurs + -- The GHCi runtime debugger does its type-matching with -- unification variables that can unify with a polytype -- or a TyCon that would usually be disallowed by bad_tc @@ -2028,70 +1997,76 @@ go :: TcType -> CheckTyEqResult go (TyVarTy tv') = go_tv tv' go (TyConApp tc tys) = go_tc tc tys - go (LitTy {}) = CTE_OK - go (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) - | InvisArg <- af - , not ghci_tv = CTE_Bad - | otherwise = go w S.<> go a S.<> go r + go (LitTy {}) = cteOK + go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) + = go w S.<> go a S.<> go r S.<> + if not ghci_tv && af == InvisArg + then impredicative + else cteOK go (AppTy fun arg) = go fun S.<> go arg go (CastTy ty co) = go ty S.<> go_co co go (CoercionTy co) = go_co co - go (ForAllTy (Bndr tv' _) ty) - | not ghci_tv = CTE_Bad - | otherwise = case lhs of - TyVarLHS tv | tv == tv' -> CTE_OK - | otherwise -> go_occ tv (tyVarKind tv') S.<> go ty - _ -> go ty + go (ForAllTy (Bndr tv' _) ty) = (case lhs of + TyVarLHS tv | tv == tv' -> go_occ (tyVarKind tv') S.<> cterClearOccursCheck (go ty) + | otherwise -> go_occ (tyVarKind tv') S.<> go ty + _ -> go ty) + S.<> + if ghci_tv then cteOK else impredicative go_tv :: TcTyVar -> CheckTyEqResult -- this slightly peculiar way of defining this means -- we don't have to evaluate this `case` at every variable -- occurrence go_tv = case lhs of - TyVarLHS tv -> \ tv' -> if tv == tv' - then CTE_Occurs - else go_occ tv (tyVarKind tv') - TyFamLHS {} -> \ _tv' -> CTE_OK + TyVarLHS tv -> \ tv' -> go_occ (tyVarKind tv') S.<> + if tv == tv' then insoluble_occurs else cteOK + TyFamLHS {} -> \ _tv' -> cteOK -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type -- For kinds, we only do an occurs check; we do not worry -- about type families or foralls -- See Note [Checking for foralls] - go_occ tv k | tv `elemVarSet` tyCoVarsOfType k = CTE_Occurs - | otherwise = CTE_OK + go_occ k = cterFromKind $ go k go_tc :: TyCon -> [TcType] -> CheckTyEqResult -- this slightly peculiar way of defining this means -- we don't have to evaluate this `case` at every tyconapp go_tc = case lhs of - TyVarLHS {} -> \ tc tys -> - if | good_tc tc -> mconcat (map go tys) - | otherwise -> CTE_Bad + TyVarLHS {} -> \ tc tys -> check_tc tc S.<> go_tc_args tc tys TyFamLHS fam_tc fam_args -> \ tc tys -> - if | tcEqTyConApps fam_tc fam_args tc tys -> CTE_Occurs - | good_tc tc -> mconcat (map go tys) - | otherwise -> CTE_Bad + if tcEqTyConApps fam_tc fam_args tc tys + then insoluble_occurs + else check_tc tc S.<> go_tc_args tc tys + -- just look at arguments, not the tycon itself + go_tc_args :: TyCon -> [TcType] -> CheckTyEqResult + go_tc_args tc tys | isGenerativeTyCon tc Nominal = foldMap go tys + | otherwise + = let (tf_args, non_tf_args) = splitAt (tyConArity tc) tys in + cterSetOccursCheckSoluble (foldMap go tf_args) S.<> foldMap go non_tf_args -- no bother about impredicativity in coercions, as they're -- inferred - go_co co | not (gopt Opt_DeferTypeErrors dflags) - , hasCoercionHoleCo co - = CTE_HoleBlocker -- Wrinkle (2) in GHC.Tc.Solver.Canonical - -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds] - -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for - -- deferred type errors. - - | TyVarLHS tv <- lhs + go_co co | TyVarLHS tv <- lhs , tv `elemVarSet` tyCoVarsOfCo co - = CTE_Occurs + = soluble_occurs S.<> maybe_hole_blocker -- Don't check coercions for type families; see commentary at top of function | otherwise - = CTE_OK + = maybe_hole_blocker + where + -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds] + -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for + -- deferred type errors + maybe_hole_blocker | not (gopt Opt_DeferTypeErrors dflags) + , hasCoercionHoleCo co + = hole_blocker - good_tc :: TyCon -> Bool - good_tc - | ghci_tv = \ _tc -> True - | otherwise = \ tc -> isTauTyCon tc && - (ty_fam_ok == YesTypeFamilies || isFamFreeTyCon tc) + | otherwise + = cteOK + + check_tc :: TyCon -> CheckTyEqResult + check_tc + | ghci_tv = \ _tc -> cteOK + | otherwise = \ tc -> (if isTauTyCon tc then cteOK else impredicative) S.<> + (if isFamFreeTyCon tc then cteOK else type_family) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -14,9 +14,6 @@ -- -- This module is an extension of @HsSyn@ syntax, for use in the type checker. module GHC.Tc.Utils.Zonk ( - -- * Extracting types from HsSyn - hsLitType, hsPatType, hsLPatType, - -- * Other HsSyn functions mkHsDictLet, mkHsApp, mkHsAppTy, mkHsCaseAlt, @@ -48,11 +45,11 @@ import GHC.Platform import GHC.Builtin.Types -import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Hs +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) @@ -99,59 +96,6 @@ import Data.List ( partition ) import Control.Arrow ( second ) -{- -************************************************************************ -* * - Extracting the type from HsSyn -* * -************************************************************************ - --} - -hsLPatType :: LPat GhcTc -> Type -hsLPatType (L _ p) = hsPatType p - -hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ _ pat _) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat _ lvar) = idType (unLoc lvar) -hsPatType (BangPat _ pat) = hsLPatType pat -hsPatType (LazyPat _ pat) = hsLPatType pat -hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _) = idType (unLoc var) -hsPatType (ViewPat ty _ _) = ty -hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty -hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty -hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make -hsPatType (SumPat tys _ _ _ ) = mkSumTy tys -hsPatType (ConPat { pat_con = lcon - , pat_con_ext = ConPatTc - { cpt_arg_tys = tys - } - }) - = conLikeResTy (unLoc lcon) tys -hsPatType (SigPat ty _ _) = ty -hsPatType (NPat ty _ _ _) = ty -hsPatType (NPlusKPat ty _ _ _ _ _) = ty -hsPatType (XPat (CoPat _ _ ty)) = ty -hsPatType SplicePat{} = panic "hsPatType: SplicePat" - -hsLitType :: HsLit (GhcPass p) -> TcType -hsLitType (HsChar _ _) = charTy -hsLitType (HsCharPrim _ _) = charPrimTy -hsLitType (HsString _ _) = stringTy -hsLitType (HsStringPrim _ _) = addrPrimTy -hsLitType (HsInt _ _) = intTy -hsLitType (HsIntPrim _ _) = intPrimTy -hsLitType (HsWordPrim _ _) = wordPrimTy -hsLitType (HsInt64Prim _ _) = int64PrimTy -hsLitType (HsWord64Prim _ _) = word64PrimTy -hsLitType (HsInteger _ _ ty) = ty -hsLitType (HsRat _ _ ty) = ty -hsLitType (HsFloatPrim _ _) = floatPrimTy -hsLitType (HsDoublePrim _ _) = doublePrimTy - {- ********************************************************************* * * Short-cuts for overloaded numeric literals @@ -444,8 +388,7 @@ zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) - ensureNotLevPoly ty' - (text "In the type of binder" <+> quotes (ppr v)) + ensureNotLevPoly ty' (LevityCheckInBinder v) return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) @@ -650,8 +593,8 @@ , fun_matches = ms , fun_ext = co_fn })) <- lbind = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id - -- Specifically /not/ zonkIdBndr; we do not - -- want to complain about a levity-polymorphic binder + -- Specifically /not/ zonkIdBndr; we do not want to + -- complain about a representation-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env' zonkLExpr ms ; return $ L loc $ @@ -808,10 +751,9 @@ zonkExpr env (HsRecSel _ (FieldOcc v occ)) = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ)) -zonkExpr _ (HsIPVar x id) - = return (HsIPVar x id) +zonkExpr _ (HsIPVar x _) = dataConCantHappen x -zonkExpr _ e@HsOverLabel{} = return e +zonkExpr _ (HsOverLabel x _) = dataConCantHappen x zonkExpr env (HsLit x (HsRat e f ty)) = do new_ty <- zonkTcTypeToTypeX env ty @@ -843,13 +785,13 @@ return (HsAppType new_ty new_e t) -- NB: the type is an HsType; can't zonk that! -zonkExpr _ e@(HsRnBracketOut _ _ _) - = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) +zonkExpr _ (HsRnBracketOut x _ _) = dataConCantHappen x -zonkExpr env (HsTcBracketOut x wrap body bs) +zonkExpr env (HsTcBracketOut ty wrap body bs) = do wrap' <- traverse zonkQuoteWrap wrap bs' <- mapM (zonk_b env) bs - return (HsTcBracketOut x wrap' body bs') + new_ty <- zonkTcTypeToTypeX env ty + return (HsTcBracketOut new_ty wrap' body bs') where zonkQuoteWrap (QuoteWrapper ev ty) = do let ev' = zonkIdOcc env ev @@ -864,11 +806,7 @@ zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) -zonkExpr env (OpApp fixity e1 op e2) - = do new_e1 <- zonkLExpr env e1 - new_op <- zonkLExpr env op - new_e2 <- zonkLExpr env e2 - return (OpApp fixity new_e1 new_op new_e2) +zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x zonkExpr env (NegApp x expr op) = do (env', new_op) <- zonkSyntaxExpr env op @@ -879,16 +817,8 @@ = do new_e <- zonkLExpr env e return (HsPar x lpar new_e rpar) -zonkExpr env (SectionL x expr op) - = do new_expr <- zonkLExpr env expr - new_op <- zonkLExpr env op - return (SectionL x new_expr new_op) - -zonkExpr env (SectionR x op expr) - = do new_op <- zonkLExpr env op - new_expr <- zonkLExpr env expr - return (SectionR x new_op new_expr) - +zonkExpr _ (SectionL x _ _) = dataConCantHappen x +zonkExpr _ (SectionR x _ _) = dataConCantHappen x zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } @@ -1124,7 +1054,7 @@ new_ids <- mapSndM (zonkExpr env) ids massert (isLiftedTypeKind (tcTypeKind new_stack_tys)) - -- desugarer assumes that this is not levity polymorphic... + -- desugarer assumes that this is not representation-polymorphic... -- but indeed it should always be lifted due to the typing -- rules for arrows @@ -1418,8 +1348,7 @@ zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; ensureNotLevPoly ty' - (text "In a wildcard pattern") + ; ensureNotLevPoly ty' LevityCheckInWildcardPattern ; return (env, WildPat ty') } zonk_pat env (VarPat x (L l v)) @@ -1445,17 +1374,10 @@ ; ty' <- zonkTcTypeToTypeX env ty ; return (env', ViewPat ty' expr' pat') } -zonk_pat env (ListPat (ListPatTc ty Nothing) pats) +zonk_pat env (ListPat ty pats) = do { ty' <- zonkTcTypeToTypeX env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat (ListPatTc ty' Nothing) pats') } - -zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) - = do { (env', wit') <- zonkSyntaxExpr env wit - ; ty2' <- zonkTcTypeToTypeX env' ty2 - ; ty' <- zonkTcTypeToTypeX env' ty - ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } + ; return (env', ListPat ty' pats') } zonk_pat env (TuplePat tys pats boxed) = do { tys' <- mapM (zonkTcTypeToTypeX env) tys @@ -1481,11 +1403,12 @@ do { new_tys <- mapM (zonkTcTypeToTypeX env) tys -- an unboxed tuple pattern (but only an unboxed tuple pattern) - -- might have levity-polymorphic arguments. Check for this badness. + -- might have representation-polymorphic arguments. + -- Check for this badness. ; case con of RealDataCon dc | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) + -> mapM_ (checkForLevPoly (LevityCheckInUnboxedTuplePattern p)) (dropRuntimeRepArgs new_tys) _ -> return () ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars @@ -1509,8 +1432,6 @@ } ) } - where - doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p zonk_pat env (LitPat x lit) = return (env, LitPat x lit) @@ -1538,13 +1459,16 @@ ; ty' <- zonkTcTypeToTypeX env2 ty ; return (extendIdZonkEnv env2 n', NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } - -zonk_pat env (XPat (CoPat co_fn pat ty)) - = do { (env', co_fn') <- zonkCoFn env co_fn +zonk_pat env (XPat ext) = case ext of + { ExpansionPat orig pat-> + do { (env, pat') <- zonk_pat env pat + ; return $ (env, XPat $ ExpansionPat orig pat') } + ; CoPat co_fn pat ty -> + do { (env', co_fn') <- zonkCoFn env co_fn ; (env'', pat') <- zonkPat env' (noLocA pat) ; ty' <- zonkTcTypeToTypeX env'' ty ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') - } + }} zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -42,6 +42,7 @@ import GHC.Core.TyCon import GHC.Core.Predicate import GHC.Tc.Types.Origin +import GHC.Tc.Errors.Types -- others: import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) @@ -69,6 +70,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad +import Data.Bifunctor import Data.Foldable import Data.Function import Data.List ( (\\), nub ) @@ -259,7 +261,10 @@ fail_with msg = do { env0 <- tcInitTidyEnv ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } + ; failWithTcM (env1 + , TcRnUnknownMessage $ + mkPlainError noHints (pprUserTypeErrorTy tidy_msg)) + } {- Note [When we don't check for ambiguity] @@ -915,10 +920,11 @@ ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } ---------------------------------------- -forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) +forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, TcRnMessage) forAllTyErr env rank ty = ( env - , vcat [ hang herald 2 (ppr_tidy env ty) + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang herald 2 (ppr_tidy env ty) , suggestion ] ) where (tvs, _rho) = tcSplitForAllTyVars ty @@ -946,10 +952,11 @@ -- If there are any constraints, the kind is *. (#11405) forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind - -> (TidyEnv, SDoc) + -> (TidyEnv, TcRnMessage) forAllEscapeErr env tvbs theta tau tau_kind = ( env - , vcat [ hang (text "Quantified type's kind mentions quantified type variable") + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Quantified type's kind mentions quantified type variable") 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) -- NB: Don't tidy this type since the tvbs were already tidied -- previously, and re-tidying them will make the names of type @@ -976,11 +983,13 @@ kinds in this way. -} -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) ubxArgTyErr env ty - = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" - , ppr_tidy env ty ] - , text "Perhaps you intended to use UnboxedTuples" ] ) + = ( env + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ sep [ text "Illegal unboxed tuple type as function argument:" + , ppr_tidy env ty ] + , text "Perhaps you intended to use UnboxedTuples" ] ) checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () checkConstraintsOK ve theta ty @@ -992,23 +1001,25 @@ checkTcM (all isEqPred theta) $ constraintTyErr (ve_tidy_env ve) ty -constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) constraintTyErr env ty - = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) + = (env + , TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal constraint in a kind:" <+> ppr_tidy env ty) -- | Reject a use of visible, dependent quantification in the type of a term. -illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) illegalVDQTyErr env ty = - (env, vcat + (env, TcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Illegal visible, dependent quantification" <+> text "in the type of a term:") 2 (ppr_tidy env ty) , text "(GHC does not yet support this)" ] ) -- | Reject uses of linear function arrows in kinds. -linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) linearFunKindErr env ty = - (env, text "Illegal linear function in a kind:" <+> ppr_tidy env ty) + (env, TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal linear function in a kind:" <+> ppr_tidy env ty) {- Note [Liberal type synonyms] @@ -1099,9 +1110,9 @@ = return () check_valid_theta env ctxt expand theta = do { dflags <- getDynFlags - ; diagnosticTcM (WarningWithFlag Opt_WarnDuplicateConstraints) - (notNull dups) - (dupPredWarn env dups) + ; let dia m = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateConstraints) noHints m + ; diagnosticTcM (notNull dups) (second dia (dupPredWarn env dups)) ; traceTc "check_valid_theta" (ppr theta) ; mapM_ (check_pred_ty env dflags ctxt expand) theta } where @@ -1294,8 +1305,11 @@ = do { result <- matchGlobalInst dflags False cls tys ; case result of OneInst { cir_what = what } - -> addDiagnosticTc (WarningWithFlag Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn what) + -> let dia = TcRnUnknownMessage $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints) + noHints + (simplifiable_constraint_warn what) + in addDiagnosticTc dia _ -> return () } where pred = mkClassPred cls tys @@ -1402,40 +1416,47 @@ , text "While checking" <+> pprUserTypeCtxt ctxt ] ) eqPredTyErr, predTupleErr, predIrredErr, - badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) + badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage) badQuantHeadErr env pred = ( env - , hang (text "Quantified predicate must have a class or type variable head:") + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Quantified predicate must have a class or type variable head:") 2 (ppr_tidy env pred) ) eqPredTyErr env pred = ( env - , text "Illegal equational constraint" <+> ppr_tidy env pred $$ + , TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal equational constraint" <+> ppr_tidy env pred $$ parens (text "Use GADTs or TypeFamilies to permit this") ) predTupleErr env pred = ( env - , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) predIrredErr env pred = ( env - , hang (text "Illegal constraint:" <+> ppr_tidy env pred) + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) -predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage) predTyVarErr env pred = (env - , vcat [ hang (text "Non type-variable argument") + , TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ hang (text "Non type-variable argument") 2 (text "in the constraint:" <+> ppr_tidy env pred) , parens (text "Use FlexibleContexts to permit this") ]) -badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badIPPred :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage) badIPPred env pred = ( env - , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) + , TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) -constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintSynErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage) constraintSynErr env kind = ( env - , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) + , TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) 2 (parens constraintKindsMsg) ) dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) @@ -1446,7 +1467,7 @@ where primaryDups = map NE.head dups -tyConArityErr :: TyCon -> [TcType] -> SDoc +tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied, -- ignoring the /invisible/ arguments, which the user does not see. @@ -1462,9 +1483,10 @@ tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) tc_type_args = length vis_tks -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc +arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage arityErr what name n m - = hsep [ text "The" <+> what, quotes (ppr name), text "should have", + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [ text "The" <+> what, quotes (ppr name), text "should have", n_arguments <> comma, text "but has been given", if m==0 then text "none" else int m] where @@ -1586,6 +1608,7 @@ InstDeclCtxt stand_alone -> not stand_alone SpecInstCtxt -> False DerivClauseCtxt -> False + SigmaCtxt -> False _ -> True check_h98_arg_shape = case ctxt of @@ -1619,13 +1642,25 @@ text "Only one type can be given in an instance head." $$ text "Use MultiParamTypeClasses if you want to allow more, or zero." - rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - tuple_class_msg = text "You can't specify an instance for a tuple constraint" + rejected_class_msg :: TcRnMessage + rejected_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ rejected_class_doc - gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") + tuple_class_msg :: TcRnMessage + tuple_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "You can't specify an instance for a tuple constraint" - abstract_class_msg = text "Cannot define instance for abstract class" + rejected_class_doc :: SDoc + rejected_class_doc = + text "Class" <+> quotes (ppr clas_nm) + <+> text "does not support user-specified instances" + + gen_inst_err :: TcRnMessage + gen_inst_err = TcRnUnknownMessage $ mkPlainError noHints $ + rejected_class_doc $$ nest 2 (text "(in Safe Haskell)") + + abstract_class_msg :: TcRnMessage + abstract_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm) mb_ty_args_msg @@ -1695,9 +1730,10 @@ dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b -- Don't bother in the kind of a forall -instTypeErr :: Class -> [Type] -> SDoc -> SDoc +instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage instTypeErr cls tys msg - = hang (hang (text "Illegal instance declaration for") + = TcRnUnknownMessage $ mkPlainError noHints $ + hang (hang (text "Illegal instance declaration for") 2 (quotes (pprClassPred cls tys))) 2 msg @@ -1850,15 +1886,16 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty | not is_tc_app - = failWithTc (hang (text "Instance head is not headed by a class:") - 2 ( ppr tau)) + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Instance head is not headed by a class:") 2 ( ppr tau)) | isNothing mb_cls - = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) , text "A class instance must be for a class" ]) | not arity_ok - = failWithTc (text "Arity mis-match in instance head") + = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Arity mis-match in instance head") | otherwise = do { setSrcSpanA head_loc $ @@ -1960,9 +1997,12 @@ -- when the predicates are individually checked for validity check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc (nestedMsg what) - | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) + | not (null bad_tvs) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (noMoreMsg bad_tvs what (ppr head_pred)) + | not (isTyFamFree pred) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (nestedMsg what) + | pred_size >= head_size = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (smallerMsg what (ppr head_pred)) | otherwise = return () -- isTyFamFree: see Note [Type families in instance contexts] where @@ -2045,8 +2085,9 @@ -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { addDiagnosticAt WarningWithoutFlag (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch fam_tc cur_branch + = do { let dia = TcRnUnknownMessage $ + mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch) + ; addDiagnosticAt (coAxBranchSpan cur_branch) dia ; return prev_branches } | otherwise = do { check_injectivity prev_branches cur_branch @@ -2115,7 +2156,8 @@ case drop (tyConArity fam_tc) typats of [] -> pure () spec_arg:_ -> - addErr $ text "Illegal oversaturated visible kind argument:" + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Illegal oversaturated visible kind argument:" <+> quotes (char '@' <> pprParendType spec_arg) -- The argument patterns, and RHS, are all boxed tau types @@ -2162,7 +2204,7 @@ extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv - Nothing -> failWithTc $ + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") 2 (vcat [ppr_eqn, suggestion]) @@ -2180,6 +2222,7 @@ let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ + TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") @@ -2202,9 +2245,9 @@ -- checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS - -> [SDoc] + -> [TcRnMessage] checkFamInstRhs lhs_tc lhs_tys famInsts - = mapMaybe check famInsts + = map (TcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts where lhs_size = sizeTyConAppArgs lhs_tc lhs_tys inst_head = pprType (TyConApp lhs_tc lhs_tys) @@ -2275,7 +2318,7 @@ dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ + = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ TcRnUnknownMessage $ mkPlainError noHints $ hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs <+> isOrAre tvs <+> what <> comma) 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" @@ -2306,7 +2349,7 @@ -- Ensure that no type family applications occur a type pattern ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ + ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ ty_fam_inst_illegal_err tf_is_invis_arg (mkTyConApp tf_tc tf_args) } where @@ -2331,9 +2374,10 @@ = sep [ text "Illegal nested" <+> what , parens undecidableMsg ] -badATErr :: Name -> Name -> SDoc +badATErr :: Name -> Name -> TcRnMessage badATErr clas op - = hsep [text "Class", quotes (ppr clas), + = TcRnUnknownMessage $ mkPlainError noHints $ + hsep [text "Class", quotes (ppr clas), text "does not have an associated type", quotes (ppr op)] @@ -2413,7 +2457,7 @@ , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 = go lr_subst1 rl_subst1 triples | otherwise - = addErrTc (pp_wrong_at_arg vis) + = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. @@ -2841,7 +2885,7 @@ checkTyConTelescope tc | bad_scope = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ + addErr $ TcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") 2 pp_tc_kind , extra diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -255,7 +255,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = Just ctxt' + , dd_ctxt = mkHsContextMaybe ctxt ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ @@ -271,7 +271,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = NewType, dd_cType = Nothing - , dd_ctxt = Just ctxt' + , dd_ctxt = mkHsContextMaybe ctxt ctxt' , dd_kindSig = ksig' , dd_cons = [con'] , dd_derivs = derivs' } @@ -291,7 +291,7 @@ $$ (Outputable.ppr adts')) ; returnJustLA $ TyClD noExtField $ ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo) - , tcdCtxt = Just cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdCtxt = mkHsContextMaybe ctxt cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' , tcdMeths = binds' @@ -342,7 +342,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = Just ctxt' + , dd_ctxt = mkHsContextMaybe ctxt ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } @@ -363,7 +363,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = NewType, dd_cType = Nothing - , dd_ctxt = Just ctxt' + , dd_ctxt = mkHsContextMaybe ctxt ctxt' , dd_kindSig = ksig' , dd_cons = [con'], dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD @@ -659,7 +659,7 @@ = do { c' <- mapM cNameN c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; returnLA $ mk_gadt_decl c' (RecConGADT $ noLocA rec_flds) ty' } + ; returnLA $ mk_gadt_decl c' (RecConGADT (noLocA rec_flds) noHsUniTok) ty' } mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs @@ -1518,7 +1518,7 @@ _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnLA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x'' y'') + returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'') | otherwise -> mk_apps (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon))) @@ -1675,9 +1675,9 @@ hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs hsTypeToArrow w = case unLoc w of HsTyVar _ _ (L _ (isExact_maybe -> Just n)) - | n == oneDataConName -> HsLinearArrow NormalSyntax Nothing - | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax - _ -> HsExplicitMult NormalSyntax Nothing w + | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok) + | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok + _ -> HsExplicitMult noHsTok w noHsUniTok -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only @@ -1912,6 +1912,22 @@ | otherwise = L loc $ HsQualTy { hst_xqual = noExtField , hst_ctxt = ctxt' , hst_body = ty } + +-- | If passed an empty 'TH.Cxt', this returns 'Nothing'. Otherwise, this +-- returns @'Just' lc@, where @lc@ is the provided @'LHsContext' 'GhcPs'@ +-- argument. +-- +-- This is much like 'mkHsQualTy', except that it returns a +-- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing +-- superclasses and datatype contexts. We wish to avoid using 'Just' in the +-- case of an empty 'TH.Cxt', as the pretty-printer for superclasses/datatype +-- contexts always prints 'Just' contexts, even if they're empty. See #20011. +mkHsContextMaybe :: TH.Cxt + -> LHsContext GhcPs + -> Maybe (LHsContext GhcPs) +mkHsContextMaybe ctxt ctxt' + | null ctxt = Nothing + | otherwise = Just ctxt' mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn) diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs --- a/compiler/GHC/Types/TyThing/Ppr.hs +++ b/compiler/GHC/Types/TyThing/Ppr.hs @@ -18,8 +18,6 @@ import GHC.Prelude -import GHC.Driver.Ppr (warnPprTrace) - import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name @@ -33,6 +31,7 @@ import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Utils.Outputable +import GHC.Utils.Trace -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API diff --git a/compiler/GHC/Types/Unique/SDFM.hs b/compiler/GHC/Types/Unique/SDFM.hs deleted file mode 100644 --- a/compiler/GHC/Types/Unique/SDFM.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -Wall #-} - --- | Like a 'UniqDFM', but maintains equivalence classes of keys sharing the --- same entry. See 'UniqSDFM'. -module GHC.Types.Unique.SDFM ( - -- * Unique-keyed, /shared/, deterministic mappings - UniqSDFM, - - emptyUSDFM, - lookupUSDFM, - equateUSDFM, addToUSDFM, - traverseUSDFM - ) where - -import GHC.Prelude - -import GHC.Types.Unique -import GHC.Types.Unique.DFM -import GHC.Utils.Outputable - --- | Either @Indirect x@, meaning the value is represented by that of @x@, or --- an @Entry@ containing containing the actual value it represents. -data Shared key ele - = Indirect !key - | Entry !ele - --- | A 'UniqDFM' whose domain is /sets/ of 'Unique's, each of which share a --- common value of type @ele@. --- Every such set (\"equivalence class\") has a distinct representative --- 'Unique'. Supports merging the entries of multiple such sets in a union-find --- like fashion. --- --- An accurate model is that of @[(Set key, Maybe ele)]@: A finite mapping from --- sets of @key@s to possibly absent entries @ele@, where the sets don't overlap. --- Example: --- @ --- m = [({u1,u3}, Just ele1), ({u2}, Just ele2), ({u4,u7}, Nothing)] --- @ --- On this model we support the following main operations: --- --- * @'lookupUSDFM' m u3 == Just ele1@, @'lookupUSDFM' m u4 == Nothing@, --- @'lookupUSDFM' m u5 == Nothing@. --- * @'equateUSDFM' m u1 u3@ is a no-op, but --- @'equateUSDFM' m u1 u2@ merges @{u1,u3}@ and @{u2}@ to point to --- @Just ele2@ and returns the old entry of @{u1,u3}@, @Just ele1@. --- * @'addToUSDFM' m u3 ele4@ sets the entry of @{u1,u3}@ to @Just ele4@. --- --- As well as a few means for traversal/conversion to list. -newtype UniqSDFM key ele - = USDFM { unUSDFM :: UniqDFM key (Shared key ele) } - -emptyUSDFM :: UniqSDFM key ele -emptyUSDFM = USDFM emptyUDFM - -lookupReprAndEntryUSDFM :: Uniquable key => UniqSDFM key ele -> key -> (key, Maybe ele) -lookupReprAndEntryUSDFM (USDFM env) = go - where - go x = case lookupUDFM env x of - Nothing -> (x, Nothing) - Just (Indirect y) -> go y - Just (Entry ele) -> (x, Just ele) - --- | @lookupSUDFM env x@ looks up an entry for @x@, looking through all --- 'Indirect's until it finds a shared 'Entry'. --- --- Examples in terms of the model (see 'UniqSDFM'): --- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 == Just ele1 --- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u4 == Nothing --- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Nothing)] u2 == Nothing -lookupUSDFM :: Uniquable key => UniqSDFM key ele -> key -> Maybe ele -lookupUSDFM usdfm x = snd (lookupReprAndEntryUSDFM usdfm x) - --- | @equateUSDFM env x y@ makes @x@ and @y@ point to the same entry, --- thereby merging @x@'s class with @y@'s. --- If both @x@ and @y@ are in the domain of the map, then @y@'s entry will be --- chosen as the new entry and @x@'s old entry will be returned. --- --- Examples in terms of the model (see 'UniqSDFM'): --- >>> equateUSDFM [] u1 u2 == (Nothing, [({u1,u2}, Nothing)]) --- >>> equateUSDFM [({u1,u3}, Just ele1)] u3 u4 == (Nothing, [({u1,u3,u4}, Just ele1)]) --- >>> equateUSDFM [({u1,u3}, Just ele1)] u4 u3 == (Nothing, [({u1,u3,u4}, Just ele1)]) --- >>> equateUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 u2 == (Just ele1, [({u2,u1,u3}, Just ele2)]) -equateUSDFM - :: Uniquable key => UniqSDFM key ele -> key -> key -> (Maybe ele, UniqSDFM key ele) -equateUSDFM usdfm@(USDFM env) x y = - case (lu x, lu y) of - ((x', _) , (y', _)) - | getUnique x' == getUnique y' -> (Nothing, usdfm) -- nothing to do - ((x', _) , (y', Nothing)) -> (Nothing, set_indirect y' x') - ((x', mb_ex), (y', _)) -> (mb_ex, set_indirect x' y') - where - lu = lookupReprAndEntryUSDFM usdfm - set_indirect a b = USDFM $ addToUDFM env a (Indirect b) - --- | @addToUSDFM env x a@ sets the entry @x@ is associated with to @a@, --- thereby modifying its whole equivalence class. --- --- Examples in terms of the model (see 'UniqSDFM'): --- >>> addToUSDFM [] u1 ele1 == [({u1}, Just ele1)] --- >>> addToUSDFM [({u1,u3}, Just ele1)] u3 ele2 == [({u1,u3}, Just ele2)] -addToUSDFM :: Uniquable key => UniqSDFM key ele -> key -> ele -> UniqSDFM key ele -addToUSDFM usdfm@(USDFM env) x v = - USDFM $ addToUDFM env (fst (lookupReprAndEntryUSDFM usdfm x)) (Entry v) - -traverseUSDFM :: forall key a b f. Applicative f => (a -> f b) -> UniqSDFM key a -> f (UniqSDFM key b) -traverseUSDFM f = fmap (USDFM . listToUDFM_Directly) . traverse g . udfmToList . unUSDFM - where - g :: (Unique, Shared key a) -> f (Unique, Shared key b) - g (u, Indirect y) = pure (u,Indirect y) - g (u, Entry a) = do - a' <- f a - pure (u,Entry a') - -instance (Outputable key, Outputable ele) => Outputable (Shared key ele) where - ppr (Indirect x) = ppr x - ppr (Entry a) = ppr a - -instance (Outputable key, Outputable ele) => Outputable (UniqSDFM key ele) where - ppr (USDFM env) = ppr env diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -30,6 +30,9 @@ findObjectLinkableMaybe, findObjectLinkable, + -- Hash cache + lookupFileCache + ) where import GHC.Prelude @@ -56,11 +59,13 @@ import GHC.Linker.Types +import GHC.Fingerprint import Data.IORef import System.Directory import System.FilePath import Control.Monad import Data.Time +import qualified Data.Map as M type FileExt = String -- Filename extension @@ -82,27 +87,40 @@ initFinderCache :: IO FinderCache initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv + <*> newIORef M.empty -- remove all the home modules from the cache; package modules are --- assumed to not move around during a session. +-- assumed to not move around during a session; also flush the file hash +-- cache flushFinderCaches :: FinderCache -> HomeUnit -> IO () -flushFinderCaches (FinderCache ref) home_unit = +flushFinderCaches (FinderCache ref file_ref) home_unit = do atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + atomicModifyIORef' file_ref $ \_ -> (M.empty, ()) where is_ext mod _ = not (isHomeInstalledModule home_unit mod) addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO () -addToFinderCache (FinderCache ref) key val = +addToFinderCache (FinderCache ref _) key val = atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) removeFromFinderCache :: FinderCache -> InstalledModule -> IO () -removeFromFinderCache (FinderCache ref) key = +removeFromFinderCache (FinderCache ref _) key = atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) -lookupFinderCache (FinderCache ref) key = do +lookupFinderCache (FinderCache ref _) key = do c <- readIORef ref return $! lookupInstalledModuleEnv c key + +lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint +lookupFileCache (FinderCache _ ref) key = do + c <- readIORef ref + case M.lookup key c of + Nothing -> do + hash <- getFileHash key + atomicModifyIORef' ref $ \c -> (M.insert key hash c, ()) + return hash + Just fp -> return fp -- ----------------------------------------------------------------------------- -- The three external entry points diff --git a/compiler/GHC/Utils/Monad/State.hs b/compiler/GHC/Utils/Monad/State.hs deleted file mode 100644 --- a/compiler/GHC/Utils/Monad/State.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE PatternSynonyms #-} - -module GHC.Utils.Monad.State where - -import GHC.Prelude - -import GHC.Exts (oneShot) - -newtype State s a = State' { runState' :: s -> (# a, s #) } - deriving (Functor) - -pattern State :: (s -> (# a, s #)) - -> State s a - --- This pattern synonym makes the monad eta-expand, --- which as a very beneficial effect on compiler performance --- See #18202. --- See Note [The one-shot state monad trick] in GHC.Utils.Monad -pattern State m <- State' m - where - State m = State' (oneShot $ \s -> m s) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/compiler/GHC/Utils/Monad/State/Lazy.hs b/compiler/GHC/Utils/Monad/State/Lazy.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Utils/Monad/State/Lazy.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | A lazy state monad. +module GHC.Utils.Monad.State.Lazy + ( -- * The State monda + State(State) + , state + , evalState + , execState + , runState + -- * Operations + , get + , gets + , put + , modify + ) where + +import GHC.Prelude + +import GHC.Exts (oneShot) + +-- | A state monad which is lazy in the state. +newtype State s a = State' { runState' :: s -> (# a, s #) } + deriving (Functor) + +pattern State :: (s -> (# a, s #)) + -> State s a + +-- This pattern synonym makes the monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- See #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern State m <- State' m + where + State m = State' (oneShot $ \s -> m s) + +instance Applicative (State s) where + pure x = State $ \s -> (# x, s #) + m <*> n = State $ \s -> case runState' m s of + (# f, s' #) -> case runState' n s' of + (# x, s'' #) -> (# f x, s'' #) + +instance Monad (State s) where + m >>= n = State $ \s -> case runState' m s of + (# r, s' #) -> runState' (n r) s' + +state :: (s -> (a, s)) -> State s a +state f = State $ \s -> case f s of + (r, s') -> (# r, s' #) + +get :: State s s +get = State $ \s -> (# s, s #) + +gets :: (s -> a) -> State s a +gets f = State $ \s -> (# f s, s #) + +put :: s -> State s () +put s' = State $ \_ -> (# (), s' #) + +modify :: (s -> s) -> State s () +modify f = State $ \s -> (# (), f s #) + + +evalState :: State s a -> s -> a +evalState s i = case runState' s i of + (# a, _ #) -> a + + +execState :: State s a -> s -> s +execState s i = case runState' s i of + (# _, s' #) -> s' + + +runState :: State s a -> s -> (a, s) +runState s i = case runState' s i of + (# a, s' #) -> (a, s') diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20210601 +version: 0.20210701 license: BSD3 license-file: LICENSE category: Development @@ -78,7 +78,7 @@ hpc == 0.6.*, exceptions == 0.10.*, parsec, - ghc-lib-parser == 0.20210601 + ghc-lib-parser == 0.20210701 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -161,6 +161,7 @@ GHC.Core.InstEnv, GHC.Core.Lint, GHC.Core.Make, + GHC.Core.Map.Expr, GHC.Core.Map.Type, GHC.Core.Multiplicity, GHC.Core.Opt.Arity, @@ -193,6 +194,7 @@ GHC.Core.Utils, GHC.CoreToIface, GHC.Data.Bag, + GHC.Data.Bool, GHC.Data.BooleanFormula, GHC.Data.EnumSet, GHC.Data.FastMutInt, @@ -215,6 +217,9 @@ GHC.Driver.Backpack.Syntax, GHC.Driver.CmdLine, GHC.Driver.Config, + GHC.Driver.Config.Diagnostic, + GHC.Driver.Config.Logger, + GHC.Driver.Config.Parser, GHC.Driver.Env, GHC.Driver.Env.Types, GHC.Driver.Errors, @@ -260,6 +265,9 @@ GHC.Hs.Utils, GHC.HsToCore.Errors.Ppr, GHC.HsToCore.Errors.Types, + GHC.HsToCore.Pmc.Ppr, + GHC.HsToCore.Pmc.Solver.Types, + GHC.HsToCore.Pmc.Types, GHC.Iface.Ext.Fields, GHC.Iface.Recomp.Binary, GHC.Iface.Syntax, @@ -312,6 +320,8 @@ GHC.Tc.Errors.Hole.FitTypes, GHC.Tc.Errors.Ppr, GHC.Tc.Errors.Types, + GHC.Tc.Solver.InertSet, + GHC.Tc.Solver.Types, GHC.Tc.Types, GHC.Tc.Types.Constraint, GHC.Tc.Types.Evidence, @@ -332,6 +342,7 @@ GHC.Types.ForeignCall, GHC.Types.ForeignStubs, GHC.Types.Hint, + GHC.Types.Hint.Ppr, GHC.Types.HpcInfo, GHC.Types.IPE, GHC.Types.Id, @@ -361,6 +372,7 @@ GHC.Types.Unique.DSet, GHC.Types.Unique.FM, GHC.Types.Unique.Map, + GHC.Types.Unique.SDFM, GHC.Types.Unique.Set, GHC.Types.Unique.Supply, GHC.Types.Var, @@ -409,12 +421,14 @@ GHC.Utils.Logger, GHC.Utils.Misc, GHC.Utils.Monad, + GHC.Utils.Monad.State.Strict, GHC.Utils.Outputable, GHC.Utils.Panic, GHC.Utils.Panic.Plain, GHC.Utils.Ppr, GHC.Utils.Ppr.Colour, GHC.Utils.TmpFs, + GHC.Utils.Trace, GHC.Version, GHCi.BinaryArray, GHCi.BreakArray, @@ -474,6 +488,13 @@ GHC.Cmm.Switch.Implement GHC.Cmm.Utils GHC.CmmToAsm + GHC.CmmToAsm.AArch64 + GHC.CmmToAsm.AArch64.CodeGen + GHC.CmmToAsm.AArch64.Cond + GHC.CmmToAsm.AArch64.Instr + GHC.CmmToAsm.AArch64.Ppr + GHC.CmmToAsm.AArch64.RegInfo + GHC.CmmToAsm.AArch64.Regs GHC.CmmToAsm.BlockLayout GHC.CmmToAsm.CFG GHC.CmmToAsm.CFG.Dominators @@ -503,6 +524,7 @@ GHC.CmmToAsm.Reg.Graph.TrivColorable GHC.CmmToAsm.Reg.Graph.X86 GHC.CmmToAsm.Reg.Linear + GHC.CmmToAsm.Reg.Linear.AArch64 GHC.CmmToAsm.Reg.Linear.Base GHC.CmmToAsm.Reg.Linear.FreeRegs GHC.CmmToAsm.Reg.Linear.JoinToTargets @@ -551,7 +573,6 @@ GHC.CmmToLlvm.Mangler GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs - GHC.Core.Map.Expr GHC.Core.Opt.CSE GHC.Core.Opt.CallArity GHC.Core.Opt.CprAnal @@ -582,12 +603,14 @@ GHC.Data.Graph.UnVar GHC.Driver.Backpack GHC.Driver.CodeOutput + GHC.Driver.Config.CmmToAsm GHC.Driver.Main GHC.Driver.Make GHC.Driver.MakeFile GHC.Driver.Pipeline GHC.HandleEncoding GHC.Hs.Stats + GHC.Hs.Syn.Type GHC.HsToCore GHC.HsToCore.Arrows GHC.HsToCore.Binds @@ -605,10 +628,7 @@ GHC.HsToCore.Pmc GHC.HsToCore.Pmc.Check GHC.HsToCore.Pmc.Desugar - GHC.HsToCore.Pmc.Ppr GHC.HsToCore.Pmc.Solver - GHC.HsToCore.Pmc.Solver.Types - GHC.HsToCore.Pmc.Types GHC.HsToCore.Pmc.Utils GHC.HsToCore.Quote GHC.HsToCore.Types @@ -732,11 +752,9 @@ GHC.Tc.Plugin GHC.Tc.Solver GHC.Tc.Solver.Canonical - GHC.Tc.Solver.InertSet GHC.Tc.Solver.Interact GHC.Tc.Solver.Monad GHC.Tc.Solver.Rewrite - GHC.Tc.Solver.Types GHC.Tc.TyCl GHC.Tc.TyCl.Build GHC.Tc.TyCl.Class @@ -755,10 +773,9 @@ GHC.ThToHs GHC.Types.Name.Shape GHC.Types.TyThing.Ppr - GHC.Types.Unique.SDFM GHC.Unit.Finder GHC.Utils.Asm - GHC.Utils.Monad.State + GHC.Utils.Monad.State.Lazy GHCi.CreateBCO GHCi.InfoTable GHCi.ObjLink diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -300,7 +300,7 @@ , ("getCurrentCCS#"," Returns the current @CostCentreStack@ (value is @NULL@ if\n not profiling). Takes a dummy argument which can be used to\n avoid the call to @getCurrentCCS\\#@ being floated out by the\n simplifier, which would result in an uninformative stack\n (\"CAF\"). ") , ("clearCCS#"," Run the supplied IO action with an empty CCS. For example, this\n is used by the interpreter to run an interpreted computation\n without the call stack showing that it was invoked from GHC. ") , ("whereFrom#"," Returns the @InfoProvEnt @ for the info table of the given object\n (value is @NULL@ if the table does not exist or there is no information\n about the closure).") - , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m a b@ permits levity-polymorphism in both @a@ and\n @b@, so that types like @Int\\# -> Int\\#@ can still be well-kinded.\n ") + , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m a b@ permits representation polymorphism in both\n @a@ and @b@, so that types like @Int\\# -> Int\\#@ can still be\n well-kinded.\n ") , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n It does not pass any information at runtime.\n See also @GHC.Magic.runRW\\#@. ") , ("void#"," This is an alias for the unboxed unit tuple constructor.\n In earlier versions of GHC, @void\\#@ was a value\n of the primitive type @Void\\#@, which is now defined to be @(\\# \\#)@.\n ") , ("Proxy#"," The type constructor @Proxy#@ is used to bear witness to some\n type variable. It's used when you want to pass around proxy values\n for doing things like modelling type applications. A @Proxy#@\n is not only unboxed, it also has a polymorphic kind, and has no\n runtime representation, being totally free. ") @@ -311,7 +311,7 @@ , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the binary object passed as the first argument with\n the given length passed as the second argument. The event will be\n emitted to the @.eventlog@ file. ") , ("traceMarker#"," Emits a marker event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ") - , ("coerce"," The function @coerce@ allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is runtime-representation polymorphic, but the\n @RuntimeRep@ type argument is marked as @Inferred@, meaning\n that it is not available for visible type application. This means\n the typechecker will accept @coerce @Int @Age 42@.\n ") + , ("coerce"," The function @coerce@ allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is representation-polymorphic, but the\n @RuntimeRep@ type argument is marked as @Inferred@, meaning\n that it is not available for visible type application. This means\n the typechecker will accept @coerce @Int @Age 42@.\n ") , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ") diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -286,998 +286,998 @@ primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy) -primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) -primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy) -primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) -primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy) -primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) -primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy) -primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) -primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#") [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) -primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#") [] [byteArrayPrimTy] (intPrimTy) -primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#") [] [byteArrayPrimTy] (addrPrimTy) -primOpInfo MutableByteArrayContents_Char = mkGenPrimOp (fsLit "mutableByteArrayContents#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (addrPrimTy) -primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy) -primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) -primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#") [] [byteArrayPrimTy] (intPrimTy) -primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) -primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) -primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) -primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) -primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#") [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) -primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (int8PrimTy) -primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) -primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) -primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (word8PrimTy) -primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) -primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy) -primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) -primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) -primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) -primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#") [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) -primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) -primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) -primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) -primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy) -primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) -primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) -primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) -primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) -primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) -primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) -primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) -primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) -primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) -primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) -primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) -primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) -primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) -primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) -primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) -primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) -primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) -primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#") [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) -primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) -primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) -primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#") [] [mkArrayArrayPrimTy] (intPrimTy) -primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) -primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy) -primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy) -primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) -primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) -primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) -primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#") [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) -primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) -primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo AddrToIntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy) -primOpInfo IntToAddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy) -primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy -primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy -primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy -primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy -primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy -primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy -primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) -primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) -primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#") [] [addrPrimTy, intPrimTy] (floatPrimTy) -primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#") [] [addrPrimTy, intPrimTy] (doublePrimTy) -primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#") [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) -primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (int8PrimTy) -primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (int16PrimTy) -primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (int32PrimTy) -primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) -primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (word8PrimTy) -primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (word16PrimTy) -primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (word32PrimTy) -primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) -primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) -primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) -primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) -primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#") [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) -primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) -primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) -primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) -primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) -primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) -primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) -primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#") [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo CasAddrOp_Word = mkGenPrimOp (fsLit "atomicCasWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo FetchAddAddrOp_Word = mkGenPrimOp (fsLit "fetchAddWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo FetchSubAddrOp_Word = mkGenPrimOp (fsLit "fetchSubWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo FetchAndAddrOp_Word = mkGenPrimOp (fsLit "fetchAndWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo FetchNandAddrOp_Word = mkGenPrimOp (fsLit "fetchNandWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo FetchOrAddrOp_Word = mkGenPrimOp (fsLit "fetchOrWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo FetchXorAddrOp_Word = mkGenPrimOp (fsLit "fetchXorWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo AtomicReadAddrOp_Word = mkGenPrimOp (fsLit "atomicReadWordAddr#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) -primOpInfo AtomicWriteAddrOp_Word = mkGenPrimOp (fsLit "atomicWriteWordAddr#") [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) -primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy])) -primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) -primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVar, betaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy) -primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])) -primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVar, betaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) -primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy])) -primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo NewIOPortrOp = mkGenPrimOp (fsLit "newIOPort#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy alphaTy])) -primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#") [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#") [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo SameIOPortOp = mkGenPrimOp (fsLit "sameIOPort#") [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, mkIOPortPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) -primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) -primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy])) -primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) -primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) -primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy) -primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) -primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#") [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy) -primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy) -primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#") [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy])) -primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#") [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) -primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#") [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) -primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#") [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) -primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#") [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy])) -primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy])) -primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#") [alphaTyVar] [alphaTy, alphaTy] (intPrimTy) -primOpInfo ParOp = mkGenPrimOp (fsLit "par#") [alphaTyVar] [alphaTy] (intPrimTy) -primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [runtimeRep1TyVar, openAlphaTyVar, runtimeRep2TyVar, openBetaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy) -primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVar] [alphaTy] (intPrimTy) -primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVar] [intPrimTy] (alphaTy) -primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) -primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#") [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy])) -primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#") [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy])) -primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#") [alphaTyVar] [alphaTy] (intPrimTy) -primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy])) -primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#") [deltaTyVar, alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) -primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [int8PrimTy] (int8X16PrimTy) -primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [int16PrimTy] (int16X8PrimTy) -primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#") [] [int32PrimTy] (int32X4PrimTy) -primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [intPrimTy] (int64X2PrimTy) -primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#") [] [int8PrimTy] (int8X32PrimTy) -primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#") [] [int16PrimTy] (int16X16PrimTy) -primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#") [] [int32PrimTy] (int32X8PrimTy) -primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [intPrimTy] (int64X4PrimTy) -primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#") [] [int8PrimTy] (int8X64PrimTy) -primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [int16PrimTy] (int16X32PrimTy) -primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [int32PrimTy] (int32X16PrimTy) -primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [intPrimTy] (int64X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [word32PrimTy] (word32X4PrimTy) -primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [wordPrimTy] (word64X2PrimTy) -primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [word32PrimTy] (word32X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [wordPrimTy] (word64X4PrimTy) -primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) -primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [word32PrimTy] (word32X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [wordPrimTy] (word64X8PrimTy) -primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) -primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#") [] [doublePrimTy] (doubleX2PrimTy) -primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#") [] [floatPrimTy] (floatX8PrimTy) -primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#") [] [doublePrimTy] (doubleX4PrimTy) -primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#") [] [floatPrimTy] (floatX16PrimTy) -primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#") [] [doublePrimTy] (doubleX8PrimTy) -primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X16PrimTy) -primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X8PrimTy) -primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X4PrimTy) -primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy) -primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X32PrimTy) -primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X16PrimTy) -primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X8PrimTy) -primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy) -primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X64PrimTy) -primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy) -primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy) -primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy) -primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) -primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy) -primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy) -primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) -primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy) -primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy) -primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) -primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) -primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy) -primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) -primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy) -primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy) -primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy) -primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy) -primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy) -primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#") [] [int8X16PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) -primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#") [] [int16X8PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) -primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#") [] [int32X4PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) -primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#") [] [int8X32PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) -primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#") [] [int16X16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) -primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#") [] [int32X8PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) -primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#") [] [int8X64PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) -primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) -primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) -primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) -primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) -primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) -primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#") [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy])) -primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#") [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) -primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#") [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) -primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#") [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) -primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#") [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) -primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#") [] [int8X16PrimTy, int8PrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#") [] [int16X8PrimTy, int16PrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#") [] [int32X4PrimTy, int32PrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#") [] [int8X32PrimTy, int8PrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#") [] [int16X16PrimTy, int16PrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#") [] [int32X8PrimTy, int32PrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#") [] [int8X64PrimTy, int8PrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#") [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#") [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#") [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#") [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#") [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecAddOp IntVec 16 W8) = mkGenPrimOp (fsLit "plusInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) -primOpInfo (VecAddOp IntVec 8 W16) = mkGenPrimOp (fsLit "plusInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) -primOpInfo (VecAddOp IntVec 4 W32) = mkGenPrimOp (fsLit "plusInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) -primOpInfo (VecAddOp IntVec 2 W64) = mkGenPrimOp (fsLit "plusInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) -primOpInfo (VecAddOp IntVec 32 W8) = mkGenPrimOp (fsLit "plusInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) -primOpInfo (VecAddOp IntVec 16 W16) = mkGenPrimOp (fsLit "plusInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) -primOpInfo (VecAddOp IntVec 8 W32) = mkGenPrimOp (fsLit "plusInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) -primOpInfo (VecAddOp IntVec 4 W64) = mkGenPrimOp (fsLit "plusInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) -primOpInfo (VecAddOp IntVec 64 W8) = mkGenPrimOp (fsLit "plusInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) -primOpInfo (VecAddOp IntVec 32 W16) = mkGenPrimOp (fsLit "plusInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) -primOpInfo (VecAddOp IntVec 16 W32) = mkGenPrimOp (fsLit "plusInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) -primOpInfo (VecAddOp IntVec 8 W64) = mkGenPrimOp (fsLit "plusInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) -primOpInfo (VecAddOp WordVec 16 W8) = mkGenPrimOp (fsLit "plusWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) -primOpInfo (VecAddOp WordVec 8 W16) = mkGenPrimOp (fsLit "plusWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) -primOpInfo (VecAddOp WordVec 4 W32) = mkGenPrimOp (fsLit "plusWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) -primOpInfo (VecAddOp WordVec 2 W64) = mkGenPrimOp (fsLit "plusWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) -primOpInfo (VecAddOp WordVec 32 W8) = mkGenPrimOp (fsLit "plusWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) -primOpInfo (VecAddOp WordVec 16 W16) = mkGenPrimOp (fsLit "plusWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) -primOpInfo (VecAddOp WordVec 8 W32) = mkGenPrimOp (fsLit "plusWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) -primOpInfo (VecAddOp WordVec 4 W64) = mkGenPrimOp (fsLit "plusWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) -primOpInfo (VecAddOp WordVec 64 W8) = mkGenPrimOp (fsLit "plusWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) -primOpInfo (VecAddOp WordVec 32 W16) = mkGenPrimOp (fsLit "plusWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) -primOpInfo (VecAddOp WordVec 16 W32) = mkGenPrimOp (fsLit "plusWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) -primOpInfo (VecAddOp WordVec 8 W64) = mkGenPrimOp (fsLit "plusWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) -primOpInfo (VecAddOp FloatVec 4 W32) = mkGenPrimOp (fsLit "plusFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) -primOpInfo (VecAddOp FloatVec 2 W64) = mkGenPrimOp (fsLit "plusDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) -primOpInfo (VecAddOp FloatVec 8 W32) = mkGenPrimOp (fsLit "plusFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) -primOpInfo (VecAddOp FloatVec 4 W64) = mkGenPrimOp (fsLit "plusDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) -primOpInfo (VecAddOp FloatVec 16 W32) = mkGenPrimOp (fsLit "plusFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) -primOpInfo (VecAddOp FloatVec 8 W64) = mkGenPrimOp (fsLit "plusDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) -primOpInfo (VecSubOp IntVec 16 W8) = mkGenPrimOp (fsLit "minusInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) -primOpInfo (VecSubOp IntVec 8 W16) = mkGenPrimOp (fsLit "minusInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) -primOpInfo (VecSubOp IntVec 4 W32) = mkGenPrimOp (fsLit "minusInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) -primOpInfo (VecSubOp IntVec 2 W64) = mkGenPrimOp (fsLit "minusInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) -primOpInfo (VecSubOp IntVec 32 W8) = mkGenPrimOp (fsLit "minusInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) -primOpInfo (VecSubOp IntVec 16 W16) = mkGenPrimOp (fsLit "minusInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) -primOpInfo (VecSubOp IntVec 8 W32) = mkGenPrimOp (fsLit "minusInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) -primOpInfo (VecSubOp IntVec 4 W64) = mkGenPrimOp (fsLit "minusInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) -primOpInfo (VecSubOp IntVec 64 W8) = mkGenPrimOp (fsLit "minusInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) -primOpInfo (VecSubOp IntVec 32 W16) = mkGenPrimOp (fsLit "minusInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) -primOpInfo (VecSubOp IntVec 16 W32) = mkGenPrimOp (fsLit "minusInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) -primOpInfo (VecSubOp IntVec 8 W64) = mkGenPrimOp (fsLit "minusInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) -primOpInfo (VecSubOp WordVec 16 W8) = mkGenPrimOp (fsLit "minusWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) -primOpInfo (VecSubOp WordVec 8 W16) = mkGenPrimOp (fsLit "minusWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) -primOpInfo (VecSubOp WordVec 4 W32) = mkGenPrimOp (fsLit "minusWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) -primOpInfo (VecSubOp WordVec 2 W64) = mkGenPrimOp (fsLit "minusWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) -primOpInfo (VecSubOp WordVec 32 W8) = mkGenPrimOp (fsLit "minusWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) -primOpInfo (VecSubOp WordVec 16 W16) = mkGenPrimOp (fsLit "minusWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) -primOpInfo (VecSubOp WordVec 8 W32) = mkGenPrimOp (fsLit "minusWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) -primOpInfo (VecSubOp WordVec 4 W64) = mkGenPrimOp (fsLit "minusWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) -primOpInfo (VecSubOp WordVec 64 W8) = mkGenPrimOp (fsLit "minusWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) -primOpInfo (VecSubOp WordVec 32 W16) = mkGenPrimOp (fsLit "minusWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) -primOpInfo (VecSubOp WordVec 16 W32) = mkGenPrimOp (fsLit "minusWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) -primOpInfo (VecSubOp WordVec 8 W64) = mkGenPrimOp (fsLit "minusWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) -primOpInfo (VecSubOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minusFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) -primOpInfo (VecSubOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minusDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) -primOpInfo (VecSubOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minusFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) -primOpInfo (VecSubOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minusDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) -primOpInfo (VecSubOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minusFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) -primOpInfo (VecSubOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minusDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) -primOpInfo (VecMulOp IntVec 16 W8) = mkGenPrimOp (fsLit "timesInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) -primOpInfo (VecMulOp IntVec 8 W16) = mkGenPrimOp (fsLit "timesInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) -primOpInfo (VecMulOp IntVec 4 W32) = mkGenPrimOp (fsLit "timesInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) -primOpInfo (VecMulOp IntVec 2 W64) = mkGenPrimOp (fsLit "timesInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) -primOpInfo (VecMulOp IntVec 32 W8) = mkGenPrimOp (fsLit "timesInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) -primOpInfo (VecMulOp IntVec 16 W16) = mkGenPrimOp (fsLit "timesInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) -primOpInfo (VecMulOp IntVec 8 W32) = mkGenPrimOp (fsLit "timesInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) -primOpInfo (VecMulOp IntVec 4 W64) = mkGenPrimOp (fsLit "timesInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) -primOpInfo (VecMulOp IntVec 64 W8) = mkGenPrimOp (fsLit "timesInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) -primOpInfo (VecMulOp IntVec 32 W16) = mkGenPrimOp (fsLit "timesInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) -primOpInfo (VecMulOp IntVec 16 W32) = mkGenPrimOp (fsLit "timesInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) -primOpInfo (VecMulOp IntVec 8 W64) = mkGenPrimOp (fsLit "timesInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) -primOpInfo (VecMulOp WordVec 16 W8) = mkGenPrimOp (fsLit "timesWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) -primOpInfo (VecMulOp WordVec 8 W16) = mkGenPrimOp (fsLit "timesWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) -primOpInfo (VecMulOp WordVec 4 W32) = mkGenPrimOp (fsLit "timesWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) -primOpInfo (VecMulOp WordVec 2 W64) = mkGenPrimOp (fsLit "timesWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) -primOpInfo (VecMulOp WordVec 32 W8) = mkGenPrimOp (fsLit "timesWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) -primOpInfo (VecMulOp WordVec 16 W16) = mkGenPrimOp (fsLit "timesWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) -primOpInfo (VecMulOp WordVec 8 W32) = mkGenPrimOp (fsLit "timesWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) -primOpInfo (VecMulOp WordVec 4 W64) = mkGenPrimOp (fsLit "timesWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) -primOpInfo (VecMulOp WordVec 64 W8) = mkGenPrimOp (fsLit "timesWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) -primOpInfo (VecMulOp WordVec 32 W16) = mkGenPrimOp (fsLit "timesWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) -primOpInfo (VecMulOp WordVec 16 W32) = mkGenPrimOp (fsLit "timesWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) -primOpInfo (VecMulOp WordVec 8 W64) = mkGenPrimOp (fsLit "timesWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) -primOpInfo (VecMulOp FloatVec 4 W32) = mkGenPrimOp (fsLit "timesFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) -primOpInfo (VecMulOp FloatVec 2 W64) = mkGenPrimOp (fsLit "timesDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) -primOpInfo (VecMulOp FloatVec 8 W32) = mkGenPrimOp (fsLit "timesFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) -primOpInfo (VecMulOp FloatVec 4 W64) = mkGenPrimOp (fsLit "timesDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) -primOpInfo (VecMulOp FloatVec 16 W32) = mkGenPrimOp (fsLit "timesFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) -primOpInfo (VecMulOp FloatVec 8 W64) = mkGenPrimOp (fsLit "timesDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) -primOpInfo (VecDivOp FloatVec 4 W32) = mkGenPrimOp (fsLit "divideFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) -primOpInfo (VecDivOp FloatVec 2 W64) = mkGenPrimOp (fsLit "divideDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) -primOpInfo (VecDivOp FloatVec 8 W32) = mkGenPrimOp (fsLit "divideFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) -primOpInfo (VecDivOp FloatVec 4 W64) = mkGenPrimOp (fsLit "divideDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) -primOpInfo (VecDivOp FloatVec 16 W32) = mkGenPrimOp (fsLit "divideFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) -primOpInfo (VecDivOp FloatVec 8 W64) = mkGenPrimOp (fsLit "divideDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) -primOpInfo (VecQuotOp IntVec 16 W8) = mkGenPrimOp (fsLit "quotInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) -primOpInfo (VecQuotOp IntVec 8 W16) = mkGenPrimOp (fsLit "quotInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) -primOpInfo (VecQuotOp IntVec 4 W32) = mkGenPrimOp (fsLit "quotInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) -primOpInfo (VecQuotOp IntVec 2 W64) = mkGenPrimOp (fsLit "quotInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) -primOpInfo (VecQuotOp IntVec 32 W8) = mkGenPrimOp (fsLit "quotInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) -primOpInfo (VecQuotOp IntVec 16 W16) = mkGenPrimOp (fsLit "quotInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) -primOpInfo (VecQuotOp IntVec 8 W32) = mkGenPrimOp (fsLit "quotInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) -primOpInfo (VecQuotOp IntVec 4 W64) = mkGenPrimOp (fsLit "quotInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) -primOpInfo (VecQuotOp IntVec 64 W8) = mkGenPrimOp (fsLit "quotInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) -primOpInfo (VecQuotOp IntVec 32 W16) = mkGenPrimOp (fsLit "quotInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) -primOpInfo (VecQuotOp IntVec 16 W32) = mkGenPrimOp (fsLit "quotInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) -primOpInfo (VecQuotOp IntVec 8 W64) = mkGenPrimOp (fsLit "quotInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) -primOpInfo (VecQuotOp WordVec 16 W8) = mkGenPrimOp (fsLit "quotWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) -primOpInfo (VecQuotOp WordVec 8 W16) = mkGenPrimOp (fsLit "quotWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) -primOpInfo (VecQuotOp WordVec 4 W32) = mkGenPrimOp (fsLit "quotWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) -primOpInfo (VecQuotOp WordVec 2 W64) = mkGenPrimOp (fsLit "quotWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) -primOpInfo (VecQuotOp WordVec 32 W8) = mkGenPrimOp (fsLit "quotWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) -primOpInfo (VecQuotOp WordVec 16 W16) = mkGenPrimOp (fsLit "quotWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) -primOpInfo (VecQuotOp WordVec 8 W32) = mkGenPrimOp (fsLit "quotWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) -primOpInfo (VecQuotOp WordVec 4 W64) = mkGenPrimOp (fsLit "quotWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) -primOpInfo (VecQuotOp WordVec 64 W8) = mkGenPrimOp (fsLit "quotWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) -primOpInfo (VecQuotOp WordVec 32 W16) = mkGenPrimOp (fsLit "quotWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) -primOpInfo (VecQuotOp WordVec 16 W32) = mkGenPrimOp (fsLit "quotWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) -primOpInfo (VecQuotOp WordVec 8 W64) = mkGenPrimOp (fsLit "quotWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) -primOpInfo (VecRemOp IntVec 16 W8) = mkGenPrimOp (fsLit "remInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) -primOpInfo (VecRemOp IntVec 8 W16) = mkGenPrimOp (fsLit "remInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) -primOpInfo (VecRemOp IntVec 4 W32) = mkGenPrimOp (fsLit "remInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) -primOpInfo (VecRemOp IntVec 2 W64) = mkGenPrimOp (fsLit "remInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) -primOpInfo (VecRemOp IntVec 32 W8) = mkGenPrimOp (fsLit "remInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) -primOpInfo (VecRemOp IntVec 16 W16) = mkGenPrimOp (fsLit "remInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) -primOpInfo (VecRemOp IntVec 8 W32) = mkGenPrimOp (fsLit "remInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) -primOpInfo (VecRemOp IntVec 4 W64) = mkGenPrimOp (fsLit "remInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) -primOpInfo (VecRemOp IntVec 64 W8) = mkGenPrimOp (fsLit "remInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) -primOpInfo (VecRemOp IntVec 32 W16) = mkGenPrimOp (fsLit "remInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) -primOpInfo (VecRemOp IntVec 16 W32) = mkGenPrimOp (fsLit "remInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) -primOpInfo (VecRemOp IntVec 8 W64) = mkGenPrimOp (fsLit "remInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) -primOpInfo (VecRemOp WordVec 16 W8) = mkGenPrimOp (fsLit "remWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) -primOpInfo (VecRemOp WordVec 8 W16) = mkGenPrimOp (fsLit "remWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) -primOpInfo (VecRemOp WordVec 4 W32) = mkGenPrimOp (fsLit "remWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) -primOpInfo (VecRemOp WordVec 2 W64) = mkGenPrimOp (fsLit "remWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) -primOpInfo (VecRemOp WordVec 32 W8) = mkGenPrimOp (fsLit "remWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) -primOpInfo (VecRemOp WordVec 16 W16) = mkGenPrimOp (fsLit "remWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) -primOpInfo (VecRemOp WordVec 8 W32) = mkGenPrimOp (fsLit "remWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) -primOpInfo (VecRemOp WordVec 4 W64) = mkGenPrimOp (fsLit "remWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) -primOpInfo (VecRemOp WordVec 64 W8) = mkGenPrimOp (fsLit "remWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) -primOpInfo (VecRemOp WordVec 32 W16) = mkGenPrimOp (fsLit "remWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) -primOpInfo (VecRemOp WordVec 16 W32) = mkGenPrimOp (fsLit "remWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) -primOpInfo (VecRemOp WordVec 8 W64) = mkGenPrimOp (fsLit "remWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) -primOpInfo (VecNegOp IntVec 16 W8) = mkGenPrimOp (fsLit "negateInt8X16#") [] [int8X16PrimTy] (int8X16PrimTy) -primOpInfo (VecNegOp IntVec 8 W16) = mkGenPrimOp (fsLit "negateInt16X8#") [] [int16X8PrimTy] (int16X8PrimTy) -primOpInfo (VecNegOp IntVec 4 W32) = mkGenPrimOp (fsLit "negateInt32X4#") [] [int32X4PrimTy] (int32X4PrimTy) -primOpInfo (VecNegOp IntVec 2 W64) = mkGenPrimOp (fsLit "negateInt64X2#") [] [int64X2PrimTy] (int64X2PrimTy) -primOpInfo (VecNegOp IntVec 32 W8) = mkGenPrimOp (fsLit "negateInt8X32#") [] [int8X32PrimTy] (int8X32PrimTy) -primOpInfo (VecNegOp IntVec 16 W16) = mkGenPrimOp (fsLit "negateInt16X16#") [] [int16X16PrimTy] (int16X16PrimTy) -primOpInfo (VecNegOp IntVec 8 W32) = mkGenPrimOp (fsLit "negateInt32X8#") [] [int32X8PrimTy] (int32X8PrimTy) -primOpInfo (VecNegOp IntVec 4 W64) = mkGenPrimOp (fsLit "negateInt64X4#") [] [int64X4PrimTy] (int64X4PrimTy) -primOpInfo (VecNegOp IntVec 64 W8) = mkGenPrimOp (fsLit "negateInt8X64#") [] [int8X64PrimTy] (int8X64PrimTy) -primOpInfo (VecNegOp IntVec 32 W16) = mkGenPrimOp (fsLit "negateInt16X32#") [] [int16X32PrimTy] (int16X32PrimTy) -primOpInfo (VecNegOp IntVec 16 W32) = mkGenPrimOp (fsLit "negateInt32X16#") [] [int32X16PrimTy] (int32X16PrimTy) -primOpInfo (VecNegOp IntVec 8 W64) = mkGenPrimOp (fsLit "negateInt64X8#") [] [int64X8PrimTy] (int64X8PrimTy) -primOpInfo (VecNegOp FloatVec 4 W32) = mkGenPrimOp (fsLit "negateFloatX4#") [] [floatX4PrimTy] (floatX4PrimTy) -primOpInfo (VecNegOp FloatVec 2 W64) = mkGenPrimOp (fsLit "negateDoubleX2#") [] [doubleX2PrimTy] (doubleX2PrimTy) -primOpInfo (VecNegOp FloatVec 8 W32) = mkGenPrimOp (fsLit "negateFloatX8#") [] [floatX8PrimTy] (floatX8PrimTy) -primOpInfo (VecNegOp FloatVec 4 W64) = mkGenPrimOp (fsLit "negateDoubleX4#") [] [doubleX4PrimTy] (doubleX4PrimTy) -primOpInfo (VecNegOp FloatVec 16 W32) = mkGenPrimOp (fsLit "negateFloatX16#") [] [floatX16PrimTy] (floatX16PrimTy) -primOpInfo (VecNegOp FloatVec 8 W64) = mkGenPrimOp (fsLit "negateDoubleX8#") [] [doubleX8PrimTy] (doubleX8PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) -primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) -primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) -primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) -primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVarSpec, deltaTyVarSpec] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [alphaTyVarSpec] [mkArrayPrimTy alphaTy] (intPrimTy) +primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [alphaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) +primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) +primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [alphaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy) +primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) +primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [alphaTyVarSpec] [mkSmallArrayPrimTy alphaTy] (intPrimTy) +primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [alphaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) +primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) +primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [alphaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy) +primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) +primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#") [deltaTyVarSpec] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) +primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#") [] [byteArrayPrimTy] (intPrimTy) +primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#") [] [byteArrayPrimTy] (addrPrimTy) +primOpInfo MutableByteArrayContents_Char = mkGenPrimOp (fsLit "mutableByteArrayContents#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (addrPrimTy) +primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy) +primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) +primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#") [] [byteArrayPrimTy] (intPrimTy) +primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) +primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) +primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) +primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) +primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#") [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) +primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (int8PrimTy) +primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) +primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) +primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (word8PrimTy) +primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) +primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy) +primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) +primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) +primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) +primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#") [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) +primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) +primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) +primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) +primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy) +primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) +primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) +primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) +primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) +primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) +primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) +primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) +primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) +primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) +primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) +primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) +primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) +primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) +primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) +primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) +primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) +primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#") [deltaTyVarSpec] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) +primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) +primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) +primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#") [] [mkArrayArrayPrimTy] (intPrimTy) +primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) +primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy) +primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy) +primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) +primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) +primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) +primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#") [deltaTyVarSpec] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) +primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) +primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo AddrToIntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy) +primOpInfo IntToAddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy) +primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy +primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy +primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy +primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy +primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy +primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy +primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) +primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#") [] [addrPrimTy, intPrimTy] (floatPrimTy) +primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#") [] [addrPrimTy, intPrimTy] (doublePrimTy) +primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#") [alphaTyVarSpec] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) +primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (int8PrimTy) +primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (int16PrimTy) +primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (int32PrimTy) +primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (word8PrimTy) +primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (word16PrimTy) +primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (word32PrimTy) +primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) +primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) +primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) +primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#") [deltaTyVarSpec, alphaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) +primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) +primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) +primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) +primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) +primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) +primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) +primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#") [alphaTyVarSpec, deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#") [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#") [deltaTyVarSpec] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo CasAddrOp_Word = mkGenPrimOp (fsLit "atomicCasWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo FetchAddAddrOp_Word = mkGenPrimOp (fsLit "fetchAddWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo FetchSubAddrOp_Word = mkGenPrimOp (fsLit "fetchSubWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo FetchAndAddrOp_Word = mkGenPrimOp (fsLit "fetchAndWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo FetchNandAddrOp_Word = mkGenPrimOp (fsLit "fetchNandWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo FetchOrAddrOp_Word = mkGenPrimOp (fsLit "fetchOrWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo FetchXorAddrOp_Word = mkGenPrimOp (fsLit "fetchXorWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo AtomicReadAddrOp_Word = mkGenPrimOp (fsLit "atomicReadWordAddr#") [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo AtomicWriteAddrOp_Word = mkGenPrimOp (fsLit "atomicWriteWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) +primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVarSpec, alphaTyVarSpec, gammaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy])) +primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) +primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [alphaTyVarSpec, runtimeRep2TyVarInf, openBetaTyVarSpec] [alphaTy] (openBetaTy) +primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVarSpec, betaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])) +primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) +primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy])) +primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo NewIOPortrOp = mkGenPrimOp (fsLit "newIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy alphaTy])) +primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkIOPortPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkIOPortPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo SameIOPortOp = mkGenPrimOp (fsLit "sameIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkIOPortPrimTy deltaTy alphaTy, mkIOPortPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [alphaTyVarSpec] [intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVarSpec] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVarSpec] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [levity1TyVarInf, levPolyTyVar1Spec, betaTyVarSpec, gammaTyVarSpec] [levPolyTy1, betaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) +primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [levity1TyVarInf, levPolyTyVar1Spec, betaTyVarSpec] [levPolyTy1, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) +primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVarSpec] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy])) +primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) +primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [levity1TyVarInf, levPolyTyVar1Spec] [levPolyTy1, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) +primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVarSpec] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [alphaTyVarSpec] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy) +primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) +primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#") [alphaTyVarSpec, betaTyVarSpec] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy) +primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [alphaTyVarSpec] [mkStableNamePrimTy alphaTy] (intPrimTy) +primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#") [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy])) +primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#") [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#") [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) +primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#") [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) +primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#") [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) +primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#") [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy])) +primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#") [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#") [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy])) +primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#") [alphaTyVarSpec] [alphaTy, alphaTy] (intPrimTy) +primOpInfo ParOp = mkGenPrimOp (fsLit "par#") [alphaTyVarSpec] [alphaTy] (intPrimTy) +primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [levity1TyVarInf, levPolyTyVar1Spec, runtimeRep2TyVarInf, openBetaTyVarSpec] [levPolyTy1, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy) +primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVarSpec] [alphaTy] (intPrimTy) +primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVarSpec] [intPrimTy] (alphaTy) +primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy])) +primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) +primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#") [alphaTyVarSpec] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) +primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#") [alphaTyVarSpec, deltaTyVarSpec] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy])) +primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#") [alphaTyVarSpec, betaTyVarSpec] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy])) +primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#") [alphaTyVarSpec] [alphaTy] (intPrimTy) +primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#") [alphaTyVarSpec, betaTyVarSpec] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy])) +primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#") [deltaTyVarSpec, alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [int8PrimTy] (int8X16PrimTy) +primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [int16PrimTy] (int16X8PrimTy) +primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#") [] [int32PrimTy] (int32X4PrimTy) +primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [intPrimTy] (int64X2PrimTy) +primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#") [] [int8PrimTy] (int8X32PrimTy) +primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#") [] [int16PrimTy] (int16X16PrimTy) +primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#") [] [int32PrimTy] (int32X8PrimTy) +primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [intPrimTy] (int64X4PrimTy) +primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#") [] [int8PrimTy] (int8X64PrimTy) +primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [int16PrimTy] (int16X32PrimTy) +primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [int32PrimTy] (int32X16PrimTy) +primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [intPrimTy] (int64X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [word32PrimTy] (word32X4PrimTy) +primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [wordPrimTy] (word64X2PrimTy) +primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [word32PrimTy] (word32X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [wordPrimTy] (word64X4PrimTy) +primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) +primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [word32PrimTy] (word32X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [wordPrimTy] (word64X8PrimTy) +primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) +primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#") [] [doublePrimTy] (doubleX2PrimTy) +primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#") [] [floatPrimTy] (floatX8PrimTy) +primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#") [] [doublePrimTy] (doubleX4PrimTy) +primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#") [] [floatPrimTy] (floatX16PrimTy) +primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#") [] [doublePrimTy] (doubleX8PrimTy) +primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X16PrimTy) +primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X8PrimTy) +primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X4PrimTy) +primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy) +primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X32PrimTy) +primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X16PrimTy) +primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X8PrimTy) +primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy) +primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X64PrimTy) +primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy) +primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy) +primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy) +primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) +primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy) +primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy) +primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) +primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy) +primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy) +primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) +primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) +primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy) +primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) +primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy) +primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy) +primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy) +primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy) +primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy) +primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#") [] [int8X16PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) +primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#") [] [int16X8PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) +primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#") [] [int32X4PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) +primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#") [] [int8X32PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) +primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#") [] [int16X16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) +primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#") [] [int32X8PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) +primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#") [] [int8X64PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) +primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) +primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) +primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) +primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) +primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) +primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#") [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy])) +primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#") [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) +primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#") [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) +primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#") [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) +primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#") [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) +primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#") [] [int8X16PrimTy, int8PrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#") [] [int16X8PrimTy, int16PrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#") [] [int32X4PrimTy, int32PrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#") [] [int8X32PrimTy, int8PrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#") [] [int16X16PrimTy, int16PrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#") [] [int32X8PrimTy, int32PrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#") [] [int8X64PrimTy, int8PrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#") [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#") [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#") [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#") [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#") [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecAddOp IntVec 16 W8) = mkGenPrimOp (fsLit "plusInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) +primOpInfo (VecAddOp IntVec 8 W16) = mkGenPrimOp (fsLit "plusInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) +primOpInfo (VecAddOp IntVec 4 W32) = mkGenPrimOp (fsLit "plusInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) +primOpInfo (VecAddOp IntVec 2 W64) = mkGenPrimOp (fsLit "plusInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) +primOpInfo (VecAddOp IntVec 32 W8) = mkGenPrimOp (fsLit "plusInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) +primOpInfo (VecAddOp IntVec 16 W16) = mkGenPrimOp (fsLit "plusInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) +primOpInfo (VecAddOp IntVec 8 W32) = mkGenPrimOp (fsLit "plusInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) +primOpInfo (VecAddOp IntVec 4 W64) = mkGenPrimOp (fsLit "plusInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) +primOpInfo (VecAddOp IntVec 64 W8) = mkGenPrimOp (fsLit "plusInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) +primOpInfo (VecAddOp IntVec 32 W16) = mkGenPrimOp (fsLit "plusInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) +primOpInfo (VecAddOp IntVec 16 W32) = mkGenPrimOp (fsLit "plusInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) +primOpInfo (VecAddOp IntVec 8 W64) = mkGenPrimOp (fsLit "plusInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) +primOpInfo (VecAddOp WordVec 16 W8) = mkGenPrimOp (fsLit "plusWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) +primOpInfo (VecAddOp WordVec 8 W16) = mkGenPrimOp (fsLit "plusWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) +primOpInfo (VecAddOp WordVec 4 W32) = mkGenPrimOp (fsLit "plusWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) +primOpInfo (VecAddOp WordVec 2 W64) = mkGenPrimOp (fsLit "plusWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) +primOpInfo (VecAddOp WordVec 32 W8) = mkGenPrimOp (fsLit "plusWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) +primOpInfo (VecAddOp WordVec 16 W16) = mkGenPrimOp (fsLit "plusWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) +primOpInfo (VecAddOp WordVec 8 W32) = mkGenPrimOp (fsLit "plusWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) +primOpInfo (VecAddOp WordVec 4 W64) = mkGenPrimOp (fsLit "plusWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) +primOpInfo (VecAddOp WordVec 64 W8) = mkGenPrimOp (fsLit "plusWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) +primOpInfo (VecAddOp WordVec 32 W16) = mkGenPrimOp (fsLit "plusWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) +primOpInfo (VecAddOp WordVec 16 W32) = mkGenPrimOp (fsLit "plusWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) +primOpInfo (VecAddOp WordVec 8 W64) = mkGenPrimOp (fsLit "plusWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) +primOpInfo (VecAddOp FloatVec 4 W32) = mkGenPrimOp (fsLit "plusFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) +primOpInfo (VecAddOp FloatVec 2 W64) = mkGenPrimOp (fsLit "plusDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) +primOpInfo (VecAddOp FloatVec 8 W32) = mkGenPrimOp (fsLit "plusFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) +primOpInfo (VecAddOp FloatVec 4 W64) = mkGenPrimOp (fsLit "plusDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) +primOpInfo (VecAddOp FloatVec 16 W32) = mkGenPrimOp (fsLit "plusFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) +primOpInfo (VecAddOp FloatVec 8 W64) = mkGenPrimOp (fsLit "plusDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) +primOpInfo (VecSubOp IntVec 16 W8) = mkGenPrimOp (fsLit "minusInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) +primOpInfo (VecSubOp IntVec 8 W16) = mkGenPrimOp (fsLit "minusInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) +primOpInfo (VecSubOp IntVec 4 W32) = mkGenPrimOp (fsLit "minusInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) +primOpInfo (VecSubOp IntVec 2 W64) = mkGenPrimOp (fsLit "minusInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) +primOpInfo (VecSubOp IntVec 32 W8) = mkGenPrimOp (fsLit "minusInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) +primOpInfo (VecSubOp IntVec 16 W16) = mkGenPrimOp (fsLit "minusInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) +primOpInfo (VecSubOp IntVec 8 W32) = mkGenPrimOp (fsLit "minusInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) +primOpInfo (VecSubOp IntVec 4 W64) = mkGenPrimOp (fsLit "minusInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) +primOpInfo (VecSubOp IntVec 64 W8) = mkGenPrimOp (fsLit "minusInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) +primOpInfo (VecSubOp IntVec 32 W16) = mkGenPrimOp (fsLit "minusInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) +primOpInfo (VecSubOp IntVec 16 W32) = mkGenPrimOp (fsLit "minusInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) +primOpInfo (VecSubOp IntVec 8 W64) = mkGenPrimOp (fsLit "minusInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) +primOpInfo (VecSubOp WordVec 16 W8) = mkGenPrimOp (fsLit "minusWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) +primOpInfo (VecSubOp WordVec 8 W16) = mkGenPrimOp (fsLit "minusWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) +primOpInfo (VecSubOp WordVec 4 W32) = mkGenPrimOp (fsLit "minusWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) +primOpInfo (VecSubOp WordVec 2 W64) = mkGenPrimOp (fsLit "minusWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) +primOpInfo (VecSubOp WordVec 32 W8) = mkGenPrimOp (fsLit "minusWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) +primOpInfo (VecSubOp WordVec 16 W16) = mkGenPrimOp (fsLit "minusWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) +primOpInfo (VecSubOp WordVec 8 W32) = mkGenPrimOp (fsLit "minusWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) +primOpInfo (VecSubOp WordVec 4 W64) = mkGenPrimOp (fsLit "minusWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) +primOpInfo (VecSubOp WordVec 64 W8) = mkGenPrimOp (fsLit "minusWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) +primOpInfo (VecSubOp WordVec 32 W16) = mkGenPrimOp (fsLit "minusWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) +primOpInfo (VecSubOp WordVec 16 W32) = mkGenPrimOp (fsLit "minusWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) +primOpInfo (VecSubOp WordVec 8 W64) = mkGenPrimOp (fsLit "minusWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) +primOpInfo (VecSubOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minusFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) +primOpInfo (VecSubOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minusDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) +primOpInfo (VecSubOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minusFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) +primOpInfo (VecSubOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minusDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) +primOpInfo (VecSubOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minusFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) +primOpInfo (VecSubOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minusDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) +primOpInfo (VecMulOp IntVec 16 W8) = mkGenPrimOp (fsLit "timesInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) +primOpInfo (VecMulOp IntVec 8 W16) = mkGenPrimOp (fsLit "timesInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) +primOpInfo (VecMulOp IntVec 4 W32) = mkGenPrimOp (fsLit "timesInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) +primOpInfo (VecMulOp IntVec 2 W64) = mkGenPrimOp (fsLit "timesInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) +primOpInfo (VecMulOp IntVec 32 W8) = mkGenPrimOp (fsLit "timesInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) +primOpInfo (VecMulOp IntVec 16 W16) = mkGenPrimOp (fsLit "timesInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) +primOpInfo (VecMulOp IntVec 8 W32) = mkGenPrimOp (fsLit "timesInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) +primOpInfo (VecMulOp IntVec 4 W64) = mkGenPrimOp (fsLit "timesInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) +primOpInfo (VecMulOp IntVec 64 W8) = mkGenPrimOp (fsLit "timesInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) +primOpInfo (VecMulOp IntVec 32 W16) = mkGenPrimOp (fsLit "timesInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) +primOpInfo (VecMulOp IntVec 16 W32) = mkGenPrimOp (fsLit "timesInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) +primOpInfo (VecMulOp IntVec 8 W64) = mkGenPrimOp (fsLit "timesInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) +primOpInfo (VecMulOp WordVec 16 W8) = mkGenPrimOp (fsLit "timesWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) +primOpInfo (VecMulOp WordVec 8 W16) = mkGenPrimOp (fsLit "timesWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) +primOpInfo (VecMulOp WordVec 4 W32) = mkGenPrimOp (fsLit "timesWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) +primOpInfo (VecMulOp WordVec 2 W64) = mkGenPrimOp (fsLit "timesWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) +primOpInfo (VecMulOp WordVec 32 W8) = mkGenPrimOp (fsLit "timesWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) +primOpInfo (VecMulOp WordVec 16 W16) = mkGenPrimOp (fsLit "timesWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) +primOpInfo (VecMulOp WordVec 8 W32) = mkGenPrimOp (fsLit "timesWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) +primOpInfo (VecMulOp WordVec 4 W64) = mkGenPrimOp (fsLit "timesWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) +primOpInfo (VecMulOp WordVec 64 W8) = mkGenPrimOp (fsLit "timesWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) +primOpInfo (VecMulOp WordVec 32 W16) = mkGenPrimOp (fsLit "timesWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) +primOpInfo (VecMulOp WordVec 16 W32) = mkGenPrimOp (fsLit "timesWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) +primOpInfo (VecMulOp WordVec 8 W64) = mkGenPrimOp (fsLit "timesWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) +primOpInfo (VecMulOp FloatVec 4 W32) = mkGenPrimOp (fsLit "timesFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) +primOpInfo (VecMulOp FloatVec 2 W64) = mkGenPrimOp (fsLit "timesDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) +primOpInfo (VecMulOp FloatVec 8 W32) = mkGenPrimOp (fsLit "timesFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) +primOpInfo (VecMulOp FloatVec 4 W64) = mkGenPrimOp (fsLit "timesDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) +primOpInfo (VecMulOp FloatVec 16 W32) = mkGenPrimOp (fsLit "timesFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) +primOpInfo (VecMulOp FloatVec 8 W64) = mkGenPrimOp (fsLit "timesDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) +primOpInfo (VecDivOp FloatVec 4 W32) = mkGenPrimOp (fsLit "divideFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy) +primOpInfo (VecDivOp FloatVec 2 W64) = mkGenPrimOp (fsLit "divideDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy) +primOpInfo (VecDivOp FloatVec 8 W32) = mkGenPrimOp (fsLit "divideFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy) +primOpInfo (VecDivOp FloatVec 4 W64) = mkGenPrimOp (fsLit "divideDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy) +primOpInfo (VecDivOp FloatVec 16 W32) = mkGenPrimOp (fsLit "divideFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy) +primOpInfo (VecDivOp FloatVec 8 W64) = mkGenPrimOp (fsLit "divideDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) +primOpInfo (VecQuotOp IntVec 16 W8) = mkGenPrimOp (fsLit "quotInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) +primOpInfo (VecQuotOp IntVec 8 W16) = mkGenPrimOp (fsLit "quotInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) +primOpInfo (VecQuotOp IntVec 4 W32) = mkGenPrimOp (fsLit "quotInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) +primOpInfo (VecQuotOp IntVec 2 W64) = mkGenPrimOp (fsLit "quotInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) +primOpInfo (VecQuotOp IntVec 32 W8) = mkGenPrimOp (fsLit "quotInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) +primOpInfo (VecQuotOp IntVec 16 W16) = mkGenPrimOp (fsLit "quotInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) +primOpInfo (VecQuotOp IntVec 8 W32) = mkGenPrimOp (fsLit "quotInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) +primOpInfo (VecQuotOp IntVec 4 W64) = mkGenPrimOp (fsLit "quotInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) +primOpInfo (VecQuotOp IntVec 64 W8) = mkGenPrimOp (fsLit "quotInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) +primOpInfo (VecQuotOp IntVec 32 W16) = mkGenPrimOp (fsLit "quotInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) +primOpInfo (VecQuotOp IntVec 16 W32) = mkGenPrimOp (fsLit "quotInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) +primOpInfo (VecQuotOp IntVec 8 W64) = mkGenPrimOp (fsLit "quotInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) +primOpInfo (VecQuotOp WordVec 16 W8) = mkGenPrimOp (fsLit "quotWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) +primOpInfo (VecQuotOp WordVec 8 W16) = mkGenPrimOp (fsLit "quotWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) +primOpInfo (VecQuotOp WordVec 4 W32) = mkGenPrimOp (fsLit "quotWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) +primOpInfo (VecQuotOp WordVec 2 W64) = mkGenPrimOp (fsLit "quotWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) +primOpInfo (VecQuotOp WordVec 32 W8) = mkGenPrimOp (fsLit "quotWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) +primOpInfo (VecQuotOp WordVec 16 W16) = mkGenPrimOp (fsLit "quotWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) +primOpInfo (VecQuotOp WordVec 8 W32) = mkGenPrimOp (fsLit "quotWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) +primOpInfo (VecQuotOp WordVec 4 W64) = mkGenPrimOp (fsLit "quotWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) +primOpInfo (VecQuotOp WordVec 64 W8) = mkGenPrimOp (fsLit "quotWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) +primOpInfo (VecQuotOp WordVec 32 W16) = mkGenPrimOp (fsLit "quotWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) +primOpInfo (VecQuotOp WordVec 16 W32) = mkGenPrimOp (fsLit "quotWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) +primOpInfo (VecQuotOp WordVec 8 W64) = mkGenPrimOp (fsLit "quotWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) +primOpInfo (VecRemOp IntVec 16 W8) = mkGenPrimOp (fsLit "remInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy) +primOpInfo (VecRemOp IntVec 8 W16) = mkGenPrimOp (fsLit "remInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy) +primOpInfo (VecRemOp IntVec 4 W32) = mkGenPrimOp (fsLit "remInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy) +primOpInfo (VecRemOp IntVec 2 W64) = mkGenPrimOp (fsLit "remInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy) +primOpInfo (VecRemOp IntVec 32 W8) = mkGenPrimOp (fsLit "remInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy) +primOpInfo (VecRemOp IntVec 16 W16) = mkGenPrimOp (fsLit "remInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy) +primOpInfo (VecRemOp IntVec 8 W32) = mkGenPrimOp (fsLit "remInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy) +primOpInfo (VecRemOp IntVec 4 W64) = mkGenPrimOp (fsLit "remInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy) +primOpInfo (VecRemOp IntVec 64 W8) = mkGenPrimOp (fsLit "remInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy) +primOpInfo (VecRemOp IntVec 32 W16) = mkGenPrimOp (fsLit "remInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy) +primOpInfo (VecRemOp IntVec 16 W32) = mkGenPrimOp (fsLit "remInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy) +primOpInfo (VecRemOp IntVec 8 W64) = mkGenPrimOp (fsLit "remInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy) +primOpInfo (VecRemOp WordVec 16 W8) = mkGenPrimOp (fsLit "remWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy) +primOpInfo (VecRemOp WordVec 8 W16) = mkGenPrimOp (fsLit "remWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy) +primOpInfo (VecRemOp WordVec 4 W32) = mkGenPrimOp (fsLit "remWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy) +primOpInfo (VecRemOp WordVec 2 W64) = mkGenPrimOp (fsLit "remWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy) +primOpInfo (VecRemOp WordVec 32 W8) = mkGenPrimOp (fsLit "remWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy) +primOpInfo (VecRemOp WordVec 16 W16) = mkGenPrimOp (fsLit "remWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy) +primOpInfo (VecRemOp WordVec 8 W32) = mkGenPrimOp (fsLit "remWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy) +primOpInfo (VecRemOp WordVec 4 W64) = mkGenPrimOp (fsLit "remWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy) +primOpInfo (VecRemOp WordVec 64 W8) = mkGenPrimOp (fsLit "remWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy) +primOpInfo (VecRemOp WordVec 32 W16) = mkGenPrimOp (fsLit "remWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy) +primOpInfo (VecRemOp WordVec 16 W32) = mkGenPrimOp (fsLit "remWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy) +primOpInfo (VecRemOp WordVec 8 W64) = mkGenPrimOp (fsLit "remWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy) +primOpInfo (VecNegOp IntVec 16 W8) = mkGenPrimOp (fsLit "negateInt8X16#") [] [int8X16PrimTy] (int8X16PrimTy) +primOpInfo (VecNegOp IntVec 8 W16) = mkGenPrimOp (fsLit "negateInt16X8#") [] [int16X8PrimTy] (int16X8PrimTy) +primOpInfo (VecNegOp IntVec 4 W32) = mkGenPrimOp (fsLit "negateInt32X4#") [] [int32X4PrimTy] (int32X4PrimTy) +primOpInfo (VecNegOp IntVec 2 W64) = mkGenPrimOp (fsLit "negateInt64X2#") [] [int64X2PrimTy] (int64X2PrimTy) +primOpInfo (VecNegOp IntVec 32 W8) = mkGenPrimOp (fsLit "negateInt8X32#") [] [int8X32PrimTy] (int8X32PrimTy) +primOpInfo (VecNegOp IntVec 16 W16) = mkGenPrimOp (fsLit "negateInt16X16#") [] [int16X16PrimTy] (int16X16PrimTy) +primOpInfo (VecNegOp IntVec 8 W32) = mkGenPrimOp (fsLit "negateInt32X8#") [] [int32X8PrimTy] (int32X8PrimTy) +primOpInfo (VecNegOp IntVec 4 W64) = mkGenPrimOp (fsLit "negateInt64X4#") [] [int64X4PrimTy] (int64X4PrimTy) +primOpInfo (VecNegOp IntVec 64 W8) = mkGenPrimOp (fsLit "negateInt8X64#") [] [int8X64PrimTy] (int8X64PrimTy) +primOpInfo (VecNegOp IntVec 32 W16) = mkGenPrimOp (fsLit "negateInt16X32#") [] [int16X32PrimTy] (int16X32PrimTy) +primOpInfo (VecNegOp IntVec 16 W32) = mkGenPrimOp (fsLit "negateInt32X16#") [] [int32X16PrimTy] (int32X16PrimTy) +primOpInfo (VecNegOp IntVec 8 W64) = mkGenPrimOp (fsLit "negateInt64X8#") [] [int64X8PrimTy] (int64X8PrimTy) +primOpInfo (VecNegOp FloatVec 4 W32) = mkGenPrimOp (fsLit "negateFloatX4#") [] [floatX4PrimTy] (floatX4PrimTy) +primOpInfo (VecNegOp FloatVec 2 W64) = mkGenPrimOp (fsLit "negateDoubleX2#") [] [doubleX2PrimTy] (doubleX2PrimTy) +primOpInfo (VecNegOp FloatVec 8 W32) = mkGenPrimOp (fsLit "negateFloatX8#") [] [floatX8PrimTy] (floatX8PrimTy) +primOpInfo (VecNegOp FloatVec 4 W64) = mkGenPrimOp (fsLit "negateDoubleX4#") [] [doubleX4PrimTy] (doubleX4PrimTy) +primOpInfo (VecNegOp FloatVec 16 W32) = mkGenPrimOp (fsLit "negateFloatX16#") [] [floatX16PrimTy] (floatX16PrimTy) +primOpInfo (VecNegOp FloatVec 8 W64) = mkGenPrimOp (fsLit "negateDoubleX8#") [] [doubleX8PrimTy] (doubleX8PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) 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 @@ -14,6 +14,11 @@ primOpStrictness CatchSTMOp = \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd ] topDiv +primOpStrictness ForkOp = \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , topDmd ] topDiv +primOpStrictness ForkOnOp = \ _arity -> mkClosedDmdSig [ topDmd + , lazyApply1Dmd + , topDmd ] topDiv primOpStrictness KeepAliveOp = \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv primOpStrictness DataToTagOp = \ _arity -> mkClosedDmdSig [evalDmd] topDiv primOpStrictness _ = \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv diff --git a/ghc-lib/stage0/lib/ghcautoconf.h b/ghc-lib/stage0/lib/ghcautoconf.h --- a/ghc-lib/stage0/lib/ghcautoconf.h +++ b/ghc-lib/stage0/lib/ghcautoconf.h @@ -610,10 +610,10 @@ /* #undef pid_t */ /* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (12) +#define sUPPORTED_LLVM_VERSION_MAX (13) /* The minimum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MIN (10) +#define sUPPORTED_LLVM_VERSION_MIN (9) /* Define to `unsigned int' if does not define. */ /* #undef size_t */ diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -1,7 +1,8 @@ import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ - || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc)) + || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \ + || defined(MACHREGS_aarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg @@ -1014,6 +1015,98 @@ # if defined(REG_HpLim) freeReg REG_HpLim = False # endif +freeReg _ = True + +#elif defined(MACHREGS_aarch64) + +-- stack pointer / zero reg +freeReg 31 = False +-- link register +freeReg 30 = False +-- frame pointer +freeReg 29 = False +-- ip0 -- used for spill offset computations +freeReg 16 = False + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif + +# if defined(REG_R1) +freeReg REG_R1 = False +# endif +# if defined(REG_R2) +freeReg REG_R2 = False +# endif +# if defined(REG_R3) +freeReg REG_R3 = False +# endif +# if defined(REG_R4) +freeReg REG_R4 = False +# endif +# if defined(REG_R5) +freeReg REG_R5 = False +# endif +# if defined(REG_R6) +freeReg REG_R6 = False +# endif +# if defined(REG_R7) +freeReg REG_R7 = False +# endif +# if defined(REG_R8) +freeReg REG_R8 = False +# endif + +# if defined(REG_F1) +freeReg REG_F1 = False +# endif +# if defined(REG_F2) +freeReg REG_F2 = False +# endif +# if defined(REG_F3) +freeReg REG_F3 = False +# endif +# if defined(REG_F4) +freeReg REG_F4 = False +# endif +# if defined(REG_F5) +freeReg REG_F5 = False +# endif +# if defined(REG_F6) +freeReg REG_F6 = False +# endif + +# if defined(REG_D1) +freeReg REG_D1 = False +# endif +# if defined(REG_D2) +freeReg REG_D2 = False +# endif +# if defined(REG_D3) +freeReg REG_D3 = False +# endif +# if defined(REG_D4) +freeReg REG_D4 = False +# endif +# if defined(REG_D5) +freeReg REG_D5 = False +# endif +# if defined(REG_D6) +freeReg REG_D6 = False +# endif + freeReg _ = True #elif defined(MACHREGS_sparc) diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h --- a/includes/stg/MachRegs.h +++ b/includes/stg/MachRegs.h @@ -548,7 +548,7 @@ r30 | LR | The Link Register r29 | FP | The Frame Pointer r19-r28 | | Callee-saved registers - r18 | | The Platform Register, if needed; + r18 | | The Platform Register, if needed; | | or temporary register r17 | IP1 | The second intra-procedure-call temporary register r16 | IP0 | The first intra-procedure-call scratch register